Imported Upstream version 8.6upstream/8.6

1218 files changed, 56504 insertions, 34215 deletions

diff --git a/.mailmap b/.mailmap
index 13c71558..51c8778f 100644
--- a/.mailmap
+++ b/.mailmap
@@ -52,6 +52,7 @@ Pierre Letouzey <pierre.letouzey@inria.fr>         letouzey <letouzey@85f007b7-5
 Assia Mahboubi <assia.mahboubi@inria.fr>           amahboub <amahboub@85f007b7-540e-0410-9357-904b9bb8a0f7>
 Evgeny Makarov <emakarov@gforge>                   emakarov <emakarov@85f007b7-540e-0410-9357-904b9bb8a0f7>
 Gregory Malecha <gmalecha@eecs.harvard.edu>        Gregory Malecha <gmalecha@cs.harvard.edu>
+Gregory Malecha <gmalecha@eecs.harvard.edu>        Gregory Malecha <gmalecha@gmail.com>
 Lionel Elie Mamane <lmamane@gforge>                lmamane <lmamane@85f007b7-540e-0410-9357-904b9bb8a0f7>
 Claude Marché <marche@gforge>                      marche <marche@85f007b7-540e-0410-9357-904b9bb8a0f7>
 Micaela Mayero <mayero@gforge>                     mayero <mayero@85f007b7-540e-0410-9357-904b9bb8a0f7>
@@ -69,6 +70,8 @@ Pierre-Marie Pédrot <pierre-marie.pedrot@inria.fr> ppedrot <ppedrot@85f007b7-54
 Loïc Pottier <pottier@gforge>                      pottier <pottier@85f007b7-540e-0410-9357-904b9bb8a0f7>
 Matthias Puech <puech@gforge>                      puech <puech@85f007b7-540e-0410-9357-904b9bb8a0f7>
 Yann Régis-Gianas <yrg@pps.univ-paris-diderot.fr>  regisgia <regisgia@85f007b7-540e-0410-9357-904b9bb8a0f7>
+Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr> Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr>
+Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr> Daniel De Rauglaudre <ddr@gforge>
 Clément Renard <clrenard@gforge>                   clrenard <clrenard@85f007b7-540e-0410-9357-904b9bb8a0f7>
 Claudio Sacerdoti Coen <sacerdot@gforge>           sacerdot <sacerdot@85f007b7-540e-0410-9357-904b9bb8a0f7>
 Vincent Siles <vsiles@gforge>                      vsiles <vsiles@85f007b7-540e-0410-9357-904b9bb8a0f7>
@@ -79,7 +82,8 @@ Arnaud Spiwack <arnaud@spiwack.net>                aspiwack <aspiwack@85f007b7-5
 Enrico Tassi <Enrico.Tassi@inria.fr>               gareuselesinge <gareuselesinge@85f007b7-540e-0410-9357-904b9bb8a0f7>
 Enrico Tassi <Enrico.Tassi@inria.fr>               Enrico Tassi <enrico.tassi@inria.fr>
 Enrico Tassi <Enrico.Tassi@inria.fr>               Enrico Tassi <gares@fettunta.org>
-Laurent Théry <thery@gforge>                       thery <thery@85f007b7-540e-0410-9357-904b9bb8a0f7>
+Laurent Théry <laurent.thery@inria.fr>             thery <thery@85f007b7-540e-0410-9357-904b9bb8a0f7>
+Laurent Théry <laurent.thery@inria.fr>             thery <thery@sophia.inria.fr>
 Benjamin Werner <werner@gforge>                    werner <werner@85f007b7-540e-0410-9357-904b9bb8a0f7>
 
 # Anonymous accounts
diff --git a/.merlin b/.merlin
index 02420c4d..24226a91 100644
--- a/.merlin
+++ b/.merlin
@@ -1,7 +1,9 @@
-FLG -rectypes
+FLG -rectypes -thread
 
 S config
 B config
+S ide
+B ide
 S lib
 B lib
 S intf
@@ -12,6 +14,8 @@ S kernel/byterun
 B kernel/byterun
 S library
 B library
+S engine
+B engine
 S pretyping
 B pretyping
 S interp
@@ -24,6 +28,8 @@ S printing
 B printing
 S parsing
 B parsing
+S stm
+B stm
 S toplevel
 B toplevel
 
@@ -33,3 +39,5 @@ S tools/coqdoc
 B tools/coqdoc
 S dev
 B dev
+
+PKG threads.posix
diff --git a/CHANGES b/CHANGES
index 531d5049..3cb0eaa2 100644
--- a/CHANGES
+++ b/CHANGES
@@ -1,3 +1,315 @@
+Changes from V8.6beta1 to V8.6
+==============================
+
+Kernel
+
+- Fixed critical bug #5248 in VM long multiplication on 32-bit
+  architectures. Was there only since 8.6beta1, so no stable release impacted.
+
+Other bug fixes in universes, type class shelving,...
+
+Changes from V8.5 to V8.6beta1
+==============================
+
+Kernel
+
+- A new, faster state-of-the-art universe constraint checker.
+
+Specification language
+
+- Giving implicit arguments explicitly to a constant with multiple
+  choices of implicit arguments does not break any more insertion of
+  further maximal implicit arguments.
+- Ability to put any pattern in binders, prefixed by quote, e.g.
+  "fun '(a,b) => ...", "λ '(a,(b,c)), ...", "Definition foo '(x,y) := ...".
+  It expands into a "let 'pattern := ..."
+
+Tactics
+
+- Flag "Bracketing Last Introduction Pattern" is now on by default.
+- Flag "Regular Subst Tactic" is now on by default: it respects the
+  initial order of hypothesis, it contracts cycles, it unfolds no
+  local definitions (common source of incompatibilities, fixable by
+  "Unset Regular Subst Tactic").
+- New flag "Refolding Reduction", now disabled by default, which turns
+  on refolding of constants/fixpoints (as in cbn) during the reductions
+  done during type inference and tactic retyping. Can be extremely
+  expensive. When set off, this recovers the 8.4 behaviour of unification
+  and type inference. Potential source of incompatibility with 8.5 developments
+  (the option is set on in Compat/Coq85.v).
+- New flag "Shrink Abstract" that minimalizes proofs generated by the abstract
+  tactical w.r.t. variables appearing in the body of the proof.
+  On by default and deprecated. Minor source of incompatibility
+  for code relying on the precise arguments of abstracted proofs.
+- Serious bugs are fixed in tactic "double induction" (source of
+  incompatibilities as soon as the inductive types have dependencies in
+  the type of their constructors; "double induction" remains however
+  deprecated).
+- In introduction patterns of the form (pat1,...,patn), n should match
+  the exact number of hypotheses introduced (except for local definitions
+  for which pattern can be omitted, as in regular pattern-matching).
+- Tactic scopes in Ltac like constr: and ltac: now require parentheses around
+  their argument.
+- Every generic argument type declares a tactic scope of the form "name:(...)"
+  where name is the name of the argument. This generalizes the constr: and ltac:
+  instances.
+- When in strict mode (i.e. in a Ltac definition), if the "intro" tactic is
+  given a free identifier, it is not bound in subsequent tactics anymore.
+  In order to introduce a binding, use e.g. the "fresh" primitive instead
+  (potential source of incompatibilities).
+- New tactics is_ind, is_const, is_proj, is_constructor for use in Ltac.
+- New goal selectors.  Sets of goals can be selected by listing integers
+  ranges. Example: "1,4-7,24: tac" focuses "tac" on goals 1,4,5,6,7,24.
+- For uniformity with "destruct"/"induction" and for a more natural
+  behavior, "injection" can now work in place by activating option
+  "Structural Injection". In this case, hypotheses are also put in the
+  context in the natural left-to-right order and the hypothesis on
+  which injection applies is cleared.
+- Tactic "contradiction" (hence "easy") now also solve goals with
+  hypotheses of the form "~True" or "t<>t" (possible source of
+  incompatibilities because of more successes in automation, but
+  generally a more intuitive strategy).
+- Option "Injection On Proofs" was renamed "Keep Proof Equalities". When
+  enabled, injection and inversion do not drop equalities between objects
+  in Prop. Still disabled by default.
+- New tactics "notypeclasses refine" and "simple notypeclasses refine" that
+  disallow typeclass resolution when typechecking their argument, for use
+  in typeclass hints.
+- Integration of LtacProf, a profiler for Ltac.
+- Reduction tactics now accept more fine-grained flags: iota is now a shorthand
+  for the new flags match, fix and cofix.
+- The ssreflect subterm selection algorithm is now accessible to tactic writers
+  through the ssrmatching plugin.
+- When used as an argument of an ltac function, "auto" without "with"
+  nor "using" clause now correctly uses only the core hint database by
+  default.
+
+Hints
+
+- Revised the syntax of [Hint Cut] to follow standard notation for regexps.
+- Hint Mode now accepts "!" which means that the mode matches only if the
+  argument's head is not an evar (it goes under applications, casts, and
+  scrutinees of matches and projections).
+- Hints can now take an optional user-given pattern, used only by
+  [typeclasses eauto] with the [Filtered Unification] option on.
+
+Typeclasses
+
+- Many new options and new engine based on the proof monad. The
+  [typeclasses eauto] tactic is now a multi-goal, multi-success tactic.
+  See reference manual for more information. It is planned to
+  replace auto and eauto in the following version. The 8.5 resolution
+  engine is still available to help solve compatibility issues.
+
+Program
+
+- The "Shrink Obligations" flag now applies to all obligations, not only
+  those solved by the automatic tactic.
+- "Shrink Obligations" is on by default and deprecated. Minor source of
+  incompatibility for code relying on the precise arguments of
+  obligations.
+
+Notations
+
+- "Bind Scope" can once again bind "Funclass" and "Sortclass".
+
+General infrastructure
+
+- New configurable warning system which can be controlled with the vernacular
+  command "Set Warnings", or, under coqc/coqtop, with the flag "-w". In
+  particular, the default is now that warnings are printed by coqc.
+- In asynchronous mode, Coq is now capable of recovering from errors and
+  continue processing the document.
+
+Tools
+
+- coqc accepts a -o option to specify the output file name
+- coqtop accepts --print-version to print Coq and OCaml versions in
+  easy to parse format
+- Setting [Printing Dependent Evars Line] can be unset to disable the
+  computation associated with printing the "dependent evars: " line in
+  -emacs mode
+- Removed the -verbose-compat-notations flag and the corresponding Set
+  Verbose Compat vernacular, since these warnings can now be silenced or
+  turned into errors using "-w".
+
+XML protocol
+
+- message format has changed, see dev/doc/changes.txt for more details.
+
+Many bug fixes, minor changes and documentation improvements are not mentioned
+here.
+
+Changes from V8.5pl2 to V8.5pl3
+===============================
+
+Critical bugfix
+
+- #4876: Guard checker incompleteness when using primitive projections
+
+Other bugfixes
+
+- #4780: Induction with universe polymorphism on was creating ill-typed terms.
+- #4673: regression in setoid_rewrite, unfolding let-ins for type unification.
+- #4754: Regression in setoid_rewrite, allow postponed unification problems to remain.
+- #4769: Anomaly with universe polymorphic schemes defined inside sections.
+- #3886: Program: duplicate obligations of mutual fixpoints.
+- #4994: Documentation typo.
+- #5008: Use the "md5" command on OpenBSD.
+- #5007: Do not assume the "TERM" environment variable is always set.
+- #4606: Output a break before a list only if there was an empty line.
+- #5001: metas not cleaned properly in clenv_refine_in.
+- #2336: incorrect glob data for module symbols (bug #2336).
+- #4832: Remove extraneous dot in error message.
+- Anomaly in printing a unification error message.
+- #4947: Options which take string arguments are not backwards compatible.
+- #4156: micromega cache files are now hidden files.
+- #4871: interrupting par:abstract kills coqtop.
+- #5043: [Admitted] lemmas pick up section variables.
+- Fix name of internal refine ("simple refine").
+- #5062: probably a typo in Strict Proofs mode.
+- #5065: Anomaly: Not a proof by induction.
+- Restore native compiler optimizations, they were disabled since 8.5!
+- #5077: failure on typing a fixpoint with evars in its type.
+- Fix recursive notation bug.
+- #5095: non relevant too strict test in let-in abstraction.
+- Ensuring that the evar name is preserved by "rename".
+- #4887: confusion between using and with in documentation of firstorder.
+- Bug in subst with let-ins.
+- #4762: eauto weaker than auto.
+- Remove if_then_else (was buggy). Use tryif instead.
+- #4970: confusion between special "{" and non special "{{" in notations.
+- #4529: primitive projections unfolding.
+- #4416: Incorrect "Error: Incorrect number of goals".
+- #4863: abstract in typeclass hint fails.
+- #5123: unshelve can impact typeclass resolution
+- Fix a collision about the meta-variable ".." in recursive notations.
+- Fix printing of info_auto.
+- #3209: Not_found due to an occur-check cycle.
+- #5097: status of evars refined by "clear" in ltac: closed wrt evars.
+- #5150: Missing dependency of the test-suite subsystems in prerequisite.
+- Fix a bug in error printing of unif constraints
+- #3941: Do not stop propagation of signals when Coq is busy.
+- #4822: Incorrect assertion in cbn.
+- #3479 parsing of "{" and "}" when a keyword starts with "{" or "}".
+- #5127: Memory corruption with the VM.
+- #5102: bullets parsing broken by calls to parse_entry.
+
+Various documentation improvements
+
+
+Changes from V8.5pl1 to V8.5pl2
+===============================
+
+Critical bugfix
+- Checksums of .vo files dependencies were not correctly checked.
+- Unicode-to-ASCII translation was not injective, leading in a soundness bug in
+  the native compiler.
+
+Other bugfixes
+
+- #4097: more efficient occur-check in presence of primitive projections
+- #4398: type_scope used consistently in "match goal".
+- #4450: eauto does not work with polymorphic lemmas
+- #4677: fix alpha-conversion in notations needing eta-expansion.
+- Fully preserve initial order of hypotheses in "Regular Subst Tactic" mode.
+- #4644: a regression in unification.
+- #4725: Function (Error: Conversion test raised an anomaly) and Program
+  (Error: Cannot infer this placeholder of type)
+- #4747: Problem building Coq 8.5pl1 with OCaml 4.03.0: Fatal warnings
+- #4752: CoqIDE crash on files not ended by ".v".
+- #4777: printing inefficiency with implicit arguments
+- #4818: "Admitted" fails due to undefined universe anomaly after calling
+  "destruct"
+- #4823: remote counter: avoid thread race on sockets
+- #4841: -verbose flag changed semantics in 8.5, is much harder to use
+- #4851: [nsatz] cannot handle duplicated hypotheses
+- #4858: Anomaly: Uncaught exception Failure("hd"). Please report. in variant
+  of nsatz
+- #4880: [nsatz_compute] generates invalid certificates if given redundant
+  hypotheses
+- #4881: synchronizing "Declare Implicit Tactic" with backtrack.
+- #4882: anomaly with Declare Implicit Tactic on hole of type with evars
+- Fix use of "Declare Implicit Tactic" in refine.
+  triggered by CoqIDE
+- #4069, #4718: congruence fails when universes are involved.
+
+Universes
+- Disallow silently dropping universe instances applied to variables
+  (forward compatible)
+- Allow explicit universe instances on notations, when they can apply
+  to the head reference of their expansion.
+
+Build infrastructure
+- New update on how to find camlp5 binary and library at configure time.
+
+Changes from V8.5 to V8.5pl1
+============================
+
+Critical bugfix
+- The subterm relation for the guard condition was incorrectly defined on
+  primitive projections (#4588)
+
+Plugin development tools
+- add a .merlin target to the makefile
+
+Various performance improvements (time, space used by .vo files)
+
+Other bugfixes
+
+- Fix order of arguments to Big.compare_case in ExtrOcamlZBigInt.v
+- Added compatibility coercions from Specif.v which were present in Coq 8.4.
+- Fixing a source of inefficiency and an artificial dependency in the printer in the congruence tactic.
+- Allow to unset the refinement mode of Instance in ML
+- Fixing an incorrect use of prod_appvect on a term which was not a product in setoid_rewrite.
+- Add -compat 8.4 econstructor tactics, and tests
+- Add compatibility Nonrecursive Elimination Schemes
+- Fixing the "No applicable tactic" non informative error message regression on apply.
+- Univs: fix get_current_context (bug #4603, part I)
+- Fix a bug in Program coercion code
+- Fix handling of arity of definitional classes.
+- #4630: Some tactics are 20x slower in 8.5 than 8.4.
+- #4627: records with no declared arity can be template polymorphic.
+- #4623: set tactic too weak with universes (regression)
+- Fix incorrect behavior of CS resolution
+- #4591: Uncaught exception in directory browsing.
+- CoqIDE is more resilient to initialization errors.
+- #4614: "Fully check the document" is uninterruptable.
+- Try eta-expansion of records only on non-recursive ones
+- Fix bug when a sort is ascribed to a Record
+- Primitive projections: protect kernel from erroneous definitions.
+- Fixed bug #4533 with previous Keyed Unification commit
+- Win: kill unreliable hence do not waitpid after kill -9 (Close #4369)
+- Fix strategy of Keyed Unification
+- #4608: Anomaly "output_value: abstract value (outside heap)".
+- #4607: do not read native code files if native compiler was disabled.
+- #4105: poor escaping in the protocol between CoqIDE and coqtop.
+- #4596: [rewrite] broke in the past few weeks.
+- #4533 (partial): respect declared global transparency of projections in unification.ml
+- #4544: Backtrack on using full betaiota reduction during keyed unification.
+- #4540: CoqIDE bottom progress bar does not update.
+- Fix regression from 8.4 in reflexivity
+- #4580: [Set Refine Instance Mode] also used for Program Instance.
+- #4582: cannot override notation [ x ]. MAY CREATE INCOMPATIBILITIES, see #4683.
+- STM: Print/Extraction have to be skipped if -quick
+- #4542: CoqIDE: STOP button also stops workers
+- STM: classify some variants of Instance as regular `Fork nodes.
+- #4574: Anomaly: Uncaught exception Invalid_argument("splay_arity").
+- Do not give a name to anonymous evars anymore. See bug #4547.
+- STM: always stock in vio files the first node (state) of a proof
+- STM: not delegate proofs that contain Vernac(Module|Require|Import), #4530
+- Don't fail fatally if PATH is not set.
+- #4537: Coq 8.5 is slower in typeclass resolution.
+- #4522: Incorrect "Warning..." on windows.
+- #4373: coqdep does not know about .vio files.
+- #3826: "Incompatible module types" is uninformative.
+- #4495: Failed assertion in metasyntax.ml.
+- #4511: evar tactic can create non-typed evars.
+- #4503: mixing universe polymorphic and monomorphic variables and definitions in sections is unsupported.
+- #4519: oops, global shadowed local universe level bindings.
+- #4506: Anomaly: File "pretyping/indrec.ml", line 169, characters 14-20: Assertion failed.
+- #4548: Coqide crashes when going back one command
+
 Changes from V8.5beta3 to V8.5
 ==============================
 
@@ -63,6 +375,13 @@ Tactics
   "intros" automatically complete the introduction of its subcomponents, as the
   the disjunctive-conjunctive introduction patterns in non-terminal position
   already do.
+- New flag "Shrink Abstract" that minimalizes proofs generated by the abstract
+  tactical w.r.t. variables appearing in the body of the proof.
+
+Program
+
+- The "Shrink Obligations" flag now applies to all obligations, not only those
+solved by the automatic tactic.
 - Importing Program no longer overrides the "exists" tactic (potential source
   of incompatibilities).
 - Hints costs are now correctly taken into account (potential source of
@@ -353,8 +672,8 @@ Tactics
 - 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 
+- 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
@@ -407,6 +726,9 @@ Tactics
 - Behavior of introduction patterns -> and <- made more uniform
   (hypothesis is cleared, rewrite in hypotheses and conclusion and
   erasing the variable when rewriting a variable).
+- 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.
 - Tactics from plugins are now active only when the corresponding module
   is imported (source of incompatibilities, solvable by adding an "Import";
   in the particular case of Omega, use "Require Import OmegaTactic").
@@ -818,7 +1140,7 @@ Extraction
   instead of accessing their body, they are now considered as axioms.
   The previous behaviour can be reactivated via the option
   "Set Extraction AccessOpaque".
-- The pretty-printer for Haskell now produces layout-independant code
+- The pretty-printer for Haskell now produces layout-independent 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"
@@ -945,9 +1267,6 @@ 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
 
@@ -1506,7 +1825,7 @@ Tactics
   Moreover, romega now has a variant "romega with *" that can be also used
   on non-Z goals (nat, N, positive) via a call to a translation tactic named
   zify (its purpose is to Z-ify your goal...). This zify may also be used
-  independantly of romega.
+  independently of romega.
 - Tactic "remember" now supports an "in" clause to remember only selected
   occurrences of a term.
 - Tactic "pose proof" supports name overwriting in case of specialization of an
diff --git a/COMPATIBILITY b/COMPATIBILITY
index eaeb2cba..d423e71d 100644
--- a/COMPATIBILITY
+++ b/COMPATIBILITY
@@ -1,9 +1,94 @@
+Potential sources of incompatibilities between Coq V8.5 and V8.6
+----------------------------------------------------------------
+
+Symptom: An obligation generated by Program or an abstracted subproof
+has different arguments.
+Cause: Set Shrink Abstract and Set Shrink Obligations are on by default
+and the subproof does not use the argument.
+Remedy:
+- Adapt the script.
+- Write an explicit lemma to prove the obligation/subproof and use it
+  instead (compatible with 8.4).
+- Unset the option for the program/proof the obligation/subproof originates
+  from.
+
+Symptom: In a goal, order of hypotheses, or absence of an equality of
+the form "x = t" or "t = x", or no unfolding of a local definition.
+Cause: This might be connected to a number of fixes in the tactic
+"subst". The former behavior can be reactivated by issuing "Unset
+Regular Subst Tactic".
+  
 Potential sources of incompatibilities between Coq V8.4 and V8.5
 ----------------------------------------------------------------
 
+* List of typical changes to be done to adapt files from Coq 8.4 *
+* to Coq 8.5 when not using compatibility option "-compat 8.4".  *
+
+Symptom: "The reference omega was not found in the current environment".
+Cause: "Require Omega" does not import the tactic "omega" any more
+Possible solutions:
+- use "Require Import OmegaTactic" (not compatible with 8.4)
+- use "Require Import Omega" (compatible with 8.4)
+- add definition "Ltac omega := Coq.omega.Omega.omega."
+  
+Symptom: "intuition" cannot solve a goal (not working anymore on non standard connective)
+Cause: "intuition" had an accidental non uniform behavior fixed on non standard connectives
+Possible solutions:
+- use "dintuition" instead; it is stronger than "intuition" and works
+  uniformly on non standard connectives, such as n-ary conjunctions or disjunctions
+  (not compatible with 8.4)
+- do the script differently
+
+Symptom: The constructor foo (in type bar) expects n arguments.
+Cause: parameters must now be given in patterns
+Possible solutions:
+- use option "Set Asymmetric Patterns" (compatible with 8.4)
+- add "_" for the parameters (not compatible with 8.4)
+- turn the parameters into implicit arguments (compatible with 8.4)
+
+Symptom: "NPeano.Nat.foo" not existing anymore
+Possible solutions:
+- use "Nat.foo" instead
+
+Symptom: typing problems with proj1_sig or similar
+Cause: coercion from sig to sigT and similar coercions have been
+  removed so as to make the initial state easier to understand for
+  beginners
+Solution: change proj1_sig into projT1 and similarly (compatible with 8.4)
+
+* Other detailed changes *
+
 (see also file CHANGES)
 
-Universe Polymorphism.
+- options for *coq* compilation (see below for ocaml).
+
+** [-I foo] is now deprecated and will not add directory foo to the
+   coq load path (only for ocaml, see below). Just replace [-I foo] by
+   [-Q foo ""] in your project file and re-generate makefile. Or
+   perform the same operation directly in your makefile if you edit it
+   by hand.
+
+** Option -R Foo bar is the same in v8.5 than in v8.4 concerning coq
+   load path.
+
+** Option [-I foo -as bar] is unchanged but discouraged unless you
+   compile ocaml code. Use -Q foo bar instead.
+
+  for more details: file CHANGES or section "Customization at launch
+  time" of the reference manual.
+
+- Command line options for ocaml  Compilation of ocaml code (plugins) 
+
+** [-I foo] is *not* deprecated to add foo to the ocaml load path.
+
+** [-I foo -as bar] adds foo to the ocaml load path *and* adds foo to
+   the coq load path with logical name bar (shortcut for -I foo -Q foo
+   bar).
+
+  for more details: file CHANGES or section "Customization at launch
+  time" of the reference manual.
+
+- Universe Polymorphism.
 
 - Refinement, unification and tactics are now aware of universes,
   resulting in more localized errors. Universe inconsistencies 
diff --git a/COPYRIGHT b/COPYRIGHT
index 006ce18f..fc4b7baa 100644
--- a/COPYRIGHT
+++ b/COPYRIGHT
@@ -1,6 +1,6 @@
                      The Coq proof assistant
 
-Copyright 1999-2015 The Coq development team, INRIA, CNRS, University
+Copyright 1999-2016 The Coq development team, INRIA, CNRS, University
 Paris Sud, University Paris 7, Ecole Polytechnique.
 
 This product includes also software developed by
@@ -9,6 +9,7 @@ This product includes also software developed by
   Claudio Sacerdoti Coen, HELM, University of Bologna, (plugins/xml)
   Pierre Corbineau, Radboud University, Nijmegen (declarative mode)
   John Harrison, University of Cambridge (csdp wrapper)
+  Georges Gonthier, Microsoft Research - Inria Joint Centre (plugins/ssrmatching)
 
 The file CREDITS contains a list of contributors.
 The credits section in the Reference Manual details contributions.
diff --git a/CREDITS b/CREDITS
index ace4648d..c6848648 100644
--- a/CREDITS
+++ b/CREDITS
@@ -54,6 +54,9 @@ plugins/setoid_ring
   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/ssrmatching
+  developed by Georges Gonthier (Microsoft Research - Inria Joint Centre, 2007-2011),
+  and Enrico Tassi (Inria-Marelle, 2011-now)
 plugins/subtac
   developed by Matthieu Sozeau (LRI, 2005-2008)
 plugins/micromega
diff --git a/INSTALL b/INSTALL
index 83c1b9f3..df9e8552 100644
--- a/INSTALL
+++ b/INSTALL
@@ -1,5 +1,5 @@
 
-            INSTALLATION PROCEDURES FOR THE COQ V8.5 SYSTEM
+            INSTALLATION PROCEDURES FOR THE COQ V8.6 SYSTEM
             -----------------------------------------------
 
 
@@ -27,13 +27,19 @@ WHAT DO YOU NEED ?
 
      port install coq
 
-   To compile Coq V8.5 yourself, you need:
+   To compile Coq V8.6 yourself, you need:
 
-   - Objective Caml version 3.12.1 or later
+   - Objective Caml version 4.01.0 or later
      (available at http://caml.inria.fr/)
 
-   - Camlp5 (version >= 6.02) (Coq compiles with Camlp4 but might be less
-     well supported)
+   - Findlib (included in OCaml binary distribution under windows,
+     probably available in your distribution and for sure at
+     http://projects.camlcity.org/projects/findlib.html)
+
+   - Camlp5 (version >= 6.02) (Coq compiles with Camlp4 but might be
+     less well supported, for instance, Objective Caml version 4.02.1
+     is then needed or a patched version of 4.01.0 as e.g. version
+     4.01.0-4 in Debian Jessie)
 
    - GNU Make version 3.81 or later
 
@@ -59,7 +65,7 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS).
    computer and that "ocamlc" (or, better, its native code version
    "ocamlc.opt") lies in a directory which is present in your $PATH
    environment variable. At the time of writing this sentence, all
-   versions of Objective Caml later or equal to 3.12.1 are
+   versions of Objective Caml later or equal to 4.01.0 are
    supported to the exception of Objective Caml 4.02.0.
 
    To get Coq in native-code, (it runs 4 to 10 times faster than
diff --git a/INSTALL.ide b/INSTALL.ide
index 6e41b2d0..cb7ca325 100644
--- a/INSTALL.ide
+++ b/INSTALL.ide
@@ -22,7 +22,7 @@ Else, read the rest of this document to compile your own CoqIde.
 
 COMPILATION REQUIREMENTS
 
-- OCaml >= 3.12.1 with native threads support.
+- OCaml >= 4.01 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.24.x.
@@ -39,7 +39,7 @@ COMPILATION REQUIREMENTS
   install GTK+ 2.x, should you need to force it for one reason
   or another.)
 - The OCaml bindings for GTK+ 2.x, lablgtk2 with support for gtksourceview2.
-  You need at least version 2.14.2.
+  You need at least version 2.16.
 
   Your distribution may contain precompiled packages. For example, for
   Debian, run
diff --git a/META.coq b/META.coq
new file mode 100644
index 00000000..5be69d5f
--- /dev/null
+++ b/META.coq
@@ -0,0 +1,249 @@
+description = "The Coq Proof Assistant Plugin API"
+version = "8.6"
+
+directory = ""
+requires = "camlp5"
+
+package "config" (
+
+  description = "Coq Configuration Variables"
+  version     = "8.6"
+
+  directory   = "config"
+
+)
+
+package "lib" (
+
+  description = "Base Coq Library"
+  version     = "8.6"
+
+  directory   = "lib"
+
+  requires         = "coq.config"
+
+  archive(byte)    = "clib.cma"
+  archive(byte)   += "lib.cma"
+
+  archive(native)  = "clib.cmxa"
+  archive(native) += "lib.cmxa"
+
+)
+
+package "vm" (
+
+  description = "Coq VM"
+
+  version     = "8.6"
+
+# EJGA FIXME: Unfortunately dllpath is dependent on the type of Coq
+# install. In a local one we'll want kernel/byterun, in a non-local
+# one we want to set it to coqlib. We should thus generate this file
+# at configure time, but let's hear for some more feedback from
+# experts.
+
+# Enable for local native & byte builds
+#  directory        = "kernel/byterun"
+
+# Enable for local byte builds and set up properly
+#  linkopts(byte)   = "-dllpath /path/to/coq/kernel/byterun/ -dllib -lcoqrun"
+
+# Disable for local byte builds
+  linkopts(byte)   = "-dllib -lcoqrun"
+  linkopts(native) = "-cclib -lcoqrun"
+
+)
+
+package "kernel" (
+
+  description = "The Coq's Kernel"
+  version     = "8.6"
+
+  directory   = "kernel"
+
+  requires    = "coq.lib, coq.vm"
+
+  archive(byte)    = "kernel.cma"
+  archive(native)  = "kernel.cmxa"
+
+)
+
+package "library" (
+
+  description = "Coq Libraries (vo) support"
+  version     = "8.6"
+
+  requires    = "coq.kernel"
+
+  directory   = "library"
+
+  archive(byte)    = "library.cma"
+  archive(native)  = "library.cmxa"
+
+)
+
+package "intf" (
+
+  description = "Coq Public Data Types"
+  version     = "8.6"
+
+  requires    = "coq.library"
+
+  directory   = "intf"
+
+)
+
+package "engine" (
+
+  description = "Coq Libraries (vo) support"
+  version     = "8.6"
+
+  requires    = "coq.library"
+  directory   = "engine"
+
+  archive(byte)    = "engine.cma"
+  archive(native)  = "engine.cmxa"
+
+)
+
+package "pretyping" (
+
+  description = "Coq Pretyper"
+  version     = "8.6"
+
+  requires    = "coq.engine"
+  directory   = "pretyping"
+
+  archive(byte)    = "pretyping.cma"
+  archive(native)  = "pretyping.cmxa"
+
+)
+
+package "interp" (
+
+  description = "Coq Term Interpretation"
+  version     = "8.6"
+
+  requires    = "coq.pretyping"
+  directory   = "interp"
+
+  archive(byte)    = "interp.cma"
+  archive(native)  = "interp.cmxa"
+
+)
+
+package "grammar" (
+
+  description = "Coq Base Grammar"
+  version     = "8.6"
+
+  requires    = "coq.interp"
+  directory   = "grammar"
+
+  archive(byte)   = "grammar.cma"
+  archive(native) = "grammar.cmxa"
+)
+
+package "proofs" (
+
+  description = "Coq Proof Engine"
+  version     = "8.6"
+
+  requires    = "coq.interp"
+  directory   = "proofs"
+
+  archive(byte)    = "proofs.cma"
+  archive(native)  = "proofs.cmxa"
+
+)
+
+package "parsing" (
+
+  description = "Coq Parsing Engine"
+  version     = "8.6"
+
+  requires    = "coq.proofs"
+  directory   = "parsing"
+
+  archive(byte)    = "parsing.cma"
+  archive(native)  = "parsing.cmxa"
+
+)
+
+package "printing" (
+
+  description = "Coq Printing Libraries"
+  version     = "8.6"
+
+  requires    = "coq.parsing"
+  directory   = "printing"
+
+  archive(byte)    = "printing.cma"
+  archive(native)  = "printing.cmxa"
+
+)
+
+package "tactics" (
+
+  description = "Coq Tactics"
+  version     = "8.6"
+
+  requires    = "coq.printing"
+  directory   = "tactics"
+
+  archive(byte)    = "tactics.cma"
+  archive(native)  = "tactics.cmxa"
+
+)
+
+package "stm" (
+
+  description = "Coq State Transactional Machine"
+  version     = "8.6"
+
+  requires    = "coq.tactics"
+  directory   = "stm"
+
+  archive(byte)    = "stm.cma"
+  archive(native)  = "stm.cmxa"
+
+)
+
+package "toplevel" (
+
+  description = "Coq Toplevel"
+  version     = "8.6"
+
+  requires    = "coq.stm"
+  directory   = "toplevel"
+
+  archive(byte)    = "toplevel.cma"
+  archive(native)  = "toplevel.cmxa"
+
+)
+
+package "highparsing" (
+
+  description = "Coq Extra Parsing"
+  version     = "8.6"
+
+  requires    = "coq.toplevel"
+  directory   = "parsing"
+
+  archive(byte)    = "highparsing.cma"
+  archive(native)  = "highparsing.cmxa"
+
+)
+
+package "ltac" (
+
+  description = "Coq LTAC Plugin"
+  version     = "8.6"
+
+  requires    = "coq.highparsing"
+  directory   = "ltac"
+
+  archive(byte)    = "ltac.cma"
+  archive(native)  = "ltac.cmxa"
+
+)
diff --git a/Makefile b/Makefile
index bb51e3dd..1dd4efca 100644
--- a/Makefile
+++ b/Makefile
@@ -59,22 +59,20 @@ define find
  $(shell find . $(FIND_VCS_CLAUSE) '(' -name $(1) ')' -print | sed 's|^\./||')
 endef
 
+define findindir
+ $(shell find $(1) $(FIND_VCS_CLAUSE) '(' -name $(2) ')' -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 MLLIBFILES := $(call find, '*.mllib') $(call find, '*.mlpack')
 export ML4FILES := $(call find, '*.ml4')
-export CFILES := $(call find, '*.c')
+export CFILES := $(call findindir, 'kernel/byterun', '*.c')
 
 # NB: The lists of currently existing .ml and .mli files will change
 # before and after a build or a make clean. Hence we do not export
@@ -86,10 +84,7 @@ EXISTINGMLI := $(call find, '*.mli')
 ## Files that will be generated
 
 GENML4FILES:= $(ML4FILES:.ml4=.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 GENMLFILES:=$(LEXFILES:.mll=.ml) tools/tolink.ml kernel/copcodes.ml
 export GENHFILES:=kernel/byterun/coq_jumptbl.h
 export GENVFILES:=theories/Numbers/Natural/BigN/NMake_gen.v
 export GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) $(GENVFILES)
@@ -126,6 +121,8 @@ help:
 	@echo "or make archclean"
 	@echo
 	@echo "For make to be verbose, add VERBOSE=1"
+	@echo
+	@echo "If you want camlp{4,5} to generate human-readable files, add READABLE_ML4=1"
 
 UNSAVED_FILES:=$(shell find . -name '.\#*v' -o -name '.\#*.ml' -o -name '.\#*.ml?')
 ifdef UNSAVED_FILES
@@ -152,10 +149,7 @@ endif
 
 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:
@@ -163,13 +157,13 @@ noconfig:
 
 # To speed-up things a bit, let's dissuade make to attempt rebuilding makefiles
 
-Makefile Makefile.build Makefile.common config/Makefile : ;
+Makefile $(wildcard Makefile.*) config/Makefile : ;
 
 ###########################################################################
 # Cleaning
 ###########################################################################
 
-.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean clean-ide ml4clean ml4depclean depclean cleanconfig distclean voclean devdocclean
+.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean clean-ide ml4clean depclean cleanconfig distclean voclean devdocclean
 
 clean: objclean cruftclean depclean docclean devdocclean
 
@@ -183,7 +177,7 @@ cruftclean: ml4clean
 
 indepclean:
 	rm -f $(GENFILES)
-	rm -f $(COQTOPBYTE) $(CHICKENBYTE) $(FAKEIDE)
+	rm -f $(COQTOPBYTE) $(CHICKENBYTE)
 	find . \( -name '*~' -o -name '*.cm[ioat]' -o -name '*.cmti' \) -delete
 	rm -f */*.pp[iox] plugins/*/*.pp[iox]
 	rm -rf $(SOURCEDOCDIR)
@@ -216,8 +210,8 @@ archclean: clean-ide optclean voclean
 	rm -f $(ALLSTDLIB).*
 
 optclean:
-	rm -f $(COQTOPEXE) $(COQMKTOP) $(COQC) $(CHICKEN) $(COQDEPBOOT)
-	rm -f $(TOOLS) $(CSDPCERT)
+	rm -f $(COQTOPEXE) $(COQMKTOP) $(CHICKEN)
+	rm -f $(TOOLS) $(PRIVATEBINARIES) $(CSDPCERT)
 	find . -name '*.cmx' -o -name '*.cmxs' -o -name '*.cmxa' -o -name '*.[soa]' -o -name '*.so' | xargs rm -f
 
 clean-ide:
@@ -230,9 +224,6 @@ clean-ide:
 ml4clean:
 	rm -f $(GENML4FILES)
 
-ml4depclean:
-	find . -name '*.ml4.d' | xargs rm -f
-
 depclean:
 	find . $(FIND_VCS_CLAUSE) '(' -name '*.d' ')' -print | xargs rm -f
 
@@ -246,6 +237,7 @@ distclean: clean cleanconfig cacheclean
 
 voclean:
 	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
+	find theories plugins test-suite -name .coq-native -empty -delete
 
 devdocclean:
 	find . -name '*.dep.ps' -o -name '*.dot' | xargs rm -f
diff --git a/Makefile.build b/Makefile.build
index 48f448ce..95df69c2 100644
--- a/Makefile.build
+++ b/Makefile.build
@@ -10,123 +10,152 @@
 # some variables.
 
 ###########################################################################
-# Starting rule
+# User-customizable variables
 ###########################################################################
 
-# build the different subsystems: coq, coqide
-world: revision coq coqide documentation
+# The following variables could be modified via the command-line of make,
+# either with the syntax 'make XYZ=1' or 'XYZ=1 make'
 
-.PHONY: world
+# To see the actual commands launched by make instead of shortened versions,
+# set this variable to 1 (or any non-empty value):
+VERBOSE ?=
+
+# If set to 1 (or non-empty) then *.ml files corresponding to *.ml4 files
+# will be generated in a human-readable format rather than in a binary format.
+READABLE_ML4 ?=
+
+# When non-empty, a time command is performed at each .v compilation.
+# To collect compilation timings of .v and import them in a spreadsheet,
+# you could hence consider: make TIMED=1 2> timings.csv
+TIMED ?=
+
+# When $(TIMED) is set, the time command used by default is $(STDTIME)
+# (see below), unless the following variable is non-empty. For instance,
+# it could be set to "'/usr/bin/time -p'".
+TIMECMD ?=
+
+# Non-empty skips the update of all dependency .d files:
+NO_RECALC_DEPS ?=
+
+# Non-empty runs the checker on all produced .vo files:
+VALIDATE ?=
+
+# Is "-xml" when building XML library:
+COQ_XML ?=
+
+###########################################################################
+# Default starting rule
+###########################################################################
+
+# build the different subsystems:
+
+world: coq coqide documentation revision
+
+coq: coqlib coqbinaries tools printers
+
+.PHONY: world coq
 
 ###########################################################################
 # Includes
 ###########################################################################
 
+# This list of ml files used to be in the main Makefile, we moved it here
+# to avoid exhausting the variable env in Win32
+MLFILES := $(MLSTATICFILES) $(GENMLFILES) $(ML4FILES:.ml4=.ml)
+
 include Makefile.common
-include Makefile.doc
+include Makefile.doc      ## provides the 'documentation' rule
+include Makefile.checker
+include Makefile.ide      ## provides the 'coqide' rule
+include Makefile.install
+include Makefile.dev      ## provides the 'printers' and 'revision' rules
 
-# In a first phase, we restrict to the basic .ml4 (the ones without grammar.cma)
+# This include below will lauch the build of all .d.
+# The - at front is for disabling warnings about currently missing ones.
+# For creating the missing .d, make will recursively build things like
+# coqdep_boot (for the .v.d files) or grammar.cma (for .ml4 -> .ml -> .ml.d).
 
-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
+DEPENDENCIES := \
+ $(addsuffix .d, $(MLFILES) $(MLIFILES) $(MLLIBFILES) $(CFILES) $(VFILES))
 
-CURDEPS:=$(addsuffix .d, $(CURFILES))
+-include $(DEPENDENCIES)
 
 # 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.
 
-.SECONDARY: $(CURDEPS) $(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.
-
--include $(CURDEPS)
-
+.SECONDARY: $(DEPENDENCIES) $(GENFILES) $(ML4FILES:.ml4=.ml)
 
 ###########################################################################
 # Compilation options
 ###########################################################################
 
-# Variables meant to be modifiable via the command-line of make
-
-VERBOSE=
-NO_RECOMPILE_ML4=
-NO_RECALC_DEPS=
-READABLE_ML4=	# 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"
-
-TIMED=          # non-empty will activate a default time command
-                # when compiling .v (see $(STDTIME) below)
+# Default timing command
+STDTIME=/usr/bin/time -f "$* (user: %U mem: %M ko)"
 
-TIMECMD=	# if you prefer a specific time command instead of $(STDTIME)
-                # e.g. "'time -p'"
-CAMLFLAGS:=${CAMLFLAGS} -w -3
-# 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
+TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD))
 
 # 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) $(NATIVECOMPUTE)
+COQOPTS=$(COQ_XML) $(NATIVECOMPUTE)
 BOOTCOQC=$(TIMER) $(COQTOPEXE) -boot $(COQOPTS) -compile
 
-# The SHOW and HIDE variables control whether make will echo complete commands 
-# or only abbreviated versions. 
-# Quiet mode is ON by default except if VERBOSE=1 option is given to make
-
-SHOW := $(if $(VERBOSE),@true "",@echo "")
-HIDE := $(if $(VERBOSE),,@)
-
 LOCALINCLUDES=$(addprefix -I , $(SRCDIRS) )
 MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB)
 
-OCAMLC := $(OCAMLC) $(CAMLFLAGS)
-OCAMLOPT := $(OCAMLOPT) $(CAMLFLAGS)
+OCAMLC := $(OCAMLFIND) ocamlc $(CAMLFLAGS)
+OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS)
 
 BYTEFLAGS=-thread $(CAMLDEBUG) $(USERFLAGS)
 OPTFLAGS=-thread $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS)
 DEPFLAGS= $(LOCALINCLUDES) -I ide -I ide/utils
 
+# On MacOS, the binaries are signed, except our private ones
 ifeq ($(shell which codesign > /dev/null 2>&1 && echo $(ARCH)),Darwin)
-LINKMETADATA=-ccopt "-sectcreate __TEXT __info_plist config/Info-$(notdir $@).plist"
-CODESIGN:=codesign -s -
+LINKMETADATA=$(if $(filter $(PRIVATEBINARIES),$@),,-ccopt "-sectcreate __TEXT __info_plist config/Info-$(notdir $@).plist")
+CODESIGN=$(if $(filter $(PRIVATEBINARIES),$@),true,codesign -s -)
 else
 LINKMETADATA=
-CODESIGN:=true
+CODESIGN=true
+endif
+
+# Best OCaml compiler, used in a generic way
+
+ifeq ($(BEST),opt)
+OPT:=opt
+BESTOBJ:=.cmx
+BESTLIB:=.cmxa
+BESTDYN:=.cmxs
+else
+OPT:=
+BESTOBJ:=.cmo
+BESTLIB:=.cma
+BESTDYN:=.cma
 endif
 
+define bestobj
+$(patsubst %.cma,%$(BESTLIB),$(patsubst %.cmo,%$(BESTOBJ),$(1)))
+endef
+
 define bestocaml
 $(if $(OPT),\
-$(if $(findstring $@,$(PRIVATEBINARIES)),\
-  $(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -o $@ $(1) $(addsuffix .cmxa,$(2)) $^ && $(STRIP) $@,\
-  $(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) $(LINKMETADATA) -o $@ $(1) $(addsuffix .cmxa,$(2)) $^ && $(STRIP) $@ && $(CODESIGN) $@),\
+$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) $(LINKMETADATA) -o $@ $(1) $(addsuffix .cmxa,$(2)) $^ && $(STRIP) $@ && $(CODESIGN) $@,\
 $(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(CUSTOM) -o $@ $(1) $(addsuffix .cma,$(2)) $^)
 endef
 
-CAMLP4DEPS=$(shell LC_ALL=C sed -n -e 's@^(\*.*camlp4deps: "\(.*\)".*@\1@p' $(1) \#))
+# Camlp4 / Camlp5 settings
+
+CAMLP4DEPS:=grammar/compat5.cmo grammar/grammar.cma
 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
+PR_O := $(if $(READABLE_ML4),pr_o.cmo,pr_dump.cmo)
 
 SYSMOD:=str unix dynlink threads
 SYSCMA:=$(addsuffix .cma,$(SYSMOD))
@@ -139,11 +168,17 @@ else
 P4CMA:=camlp4lib.cma
 endif
 
-
 ###########################################################################
 # Infrastructure for the rest of the Makefile
 ###########################################################################
 
+# The SHOW and HIDE variables control whether make will echo complete commands
+# or only abbreviated versions.
+# Quiet mode is ON by default except if VERBOSE=1 option is given to make
+
+SHOW := $(if $(VERBOSE),@true "",@echo "")
+HIDE := $(if $(VERBOSE),,@)
+
 define order-only-template
  ifeq "order-only" "$(1)"
    ORDER_ONLY_SEP:=|
@@ -164,13 +199,8 @@ ifdef VALIDATE
  VO_TOOLS_DEP += $(CHICKEN)
 endif
 
-ifdef NO_RECALC_DEPS
-  D_DEPEND_BEFORE_SRC:=|
-  D_DEPEND_AFTER_SRC:=
-else
-  D_DEPEND_BEFORE_SRC:=
-  D_DEPEND_AFTER_SRC:=|
-endif
+D_DEPEND_BEFORE_SRC := $(if $(NO_RECALC_DEPS),|,)
+D_DEPEND_AFTER_SRC := $(if $(NO_RECALC_DEPS),,|)
 
 ## When a rule redirects stdout of a command to the target file : cmd > $@
 ## then the target file will be created even if cmd has failed.
@@ -180,21 +210,18 @@ endif
 TOTARGET = > "$@" || (RV=$$?; rm -f "$@"; exit $${RV})
 
 ###########################################################################
-# Compilation option for .c files 
+# Compilation of .c files
 ###########################################################################
 
 CINCLUDES= -I $(CAMLHLIB)
 
-# libcoqrun.a, dllcoqrun.so
-
 # NB: We used to do a ranlib after ocamlmklib, but it seems that
 # ocamlmklib is already doing it
 
-$(LIBCOQRUN): kernel/byterun/coq_jumptbl.h $(BYTERUN) 
+$(LIBCOQRUN): kernel/byterun/coq_jumptbl.h $(BYTERUN)
 	cd $(dir $(LIBCOQRUN)) && \
-	$(OCAMLMKLIB) -oc $(COQRUN) $(foreach u,$(BYTERUN),$(notdir $(u)))
+	$(OCAMLFIND) ocamlmklib -oc $(COQRUN) $(foreach u,$(BYTERUN),$(notdir $(u)))
 
-#coq_jumptbl.h is required only if you have GCC 2.0 or later
 kernel/byterun/coq_jumptbl.h : kernel/byterun/coq_instruct.h
 	sed -n -e '/^  /s/ \([A-Z]\)/ \&\&coq_lbl_\1/gp' \
                -e '/^}/q' $< $(TOTARGET)
@@ -203,777 +230,315 @@ kernel/copcodes.ml: kernel/byterun/coq_instruct.h
 	sed -n -e '/^enum/p' -e 's/,//g' -e '/^  /p' $< | \
 	awk -f kernel/make-opcodes $(TOTARGET)
 
-###########################################################################
-# Main targets (coqmktop, coqtop.opt, coqtop.byte)
-###########################################################################
-
-.PHONY: coqbinaries coq coqlib coqlight states
-
-coqbinaries: ${COQBINARIES} ${CSDPCERT} ${FAKEIDE}
-
-coq: coqlib tools coqbinaries
-
-coqlib: theories plugins
-
-coqlight: theories-light tools coqbinaries
-
-states: theories/Init/Prelude.vo
+%.o: %.c
+	$(SHOW)'OCAMLC    $<'
+	$(HIDE)cd $(dir $<) && $(OCAMLC) -ccopt "$(CFLAGS)" -c $(notdir $<)
 
-miniopt: $(COQTOPEXE) pluginsopt
-minibyte: $(COQTOPBYTE) pluginsbyte
+%_stubs.c.d: $(D_DEPEND_BEFORE_SRC) %_stubs.c $(D_DEPEND_AFTER_SRC)
+	$(SHOW)'CCDEP	$<'
+	$(HIDE)echo "$@ $(@:.c.d=.o): $(@:.c.d=.c)" > $@
 
-ifeq ($(BEST),opt)
-$(COQTOPEXE): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN) $(TOPLOOPCMA:.cma=.cmxs)
-	$(SHOW)'COQMKTOP -o $@'	
-	$(HIDE)$(COQMKTOP) -boot -opt $(OPTFLAGS) $(LINKMETADATA) -thread -o $@
-	$(STRIP) $@
-	$(CODESIGN) $@
-else
-$(COQTOPEXE): $(COQTOPBYTE)
-	cp $< $@
-endif
+%.c.d: $(D_DEPEND_BEFORE_SRC) %.c $(D_DEPEND_AFTER_SRC) $(GENHFILES)
+	$(SHOW)'CCDEP     $<'
+	$(HIDE)$(OCAMLC) -ccopt "-MM -MQ $@ -MQ $(<:.c=.o) -isystem $(CAMLHLIB)" $< $(TOTARGET)
 
-$(COQTOPBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) $(TOPLOOPCMA)
-	$(SHOW)'COQMKTOP -o $@'	
-	$(HIDE)$(COQMKTOP) -boot -top $(BYTEFLAGS) -thread -o $@
+###########################################################################
+### Special rules (Camlp5 / Camlp4)
+###########################################################################
 
-LOCALCHKLIBS:=$(addprefix -I , $(CHKSRCDIRS) )
-CHKLIBS:=$(LOCALCHKLIBS) -I $(MYCAMLP4LIB)
+# Special rule for the compatibility-with-camlp5 extension for camlp4
+#
+# - grammar/compat5.cmo changes 'GEXTEND' into 'EXTEND'. Safe, always loaded
+# - grammar/compat5b.cmo changes 'EXTEND' into 'EXTEND Gram'. Interact badly with
+#    syntax such that 'VERNAC EXTEND', we only load it in grammar/
 
-ifeq ($(BEST),opt)
-$(CHICKEN): checker/check.cmxa checker/main.ml
-	$(SHOW)'OCAMLOPT -o $@'
-	$(HIDE)$(OCAMLOPT) $(CHKLIBS) $(OPTFLAGS) $(LINKMETADATA) -thread -o $@ $(SYSCMXA) $^
-	$(STRIP) $@
-	$(CODESIGN) $@
+ifeq ($(CAMLP4),camlp4)
+grammar/compat5.cmo: grammar/compat5.mlp
+	$(OCAMLC) -c -I $(MYCAMLP4LIB) -pp '$(CAMLP4O) -I $(MYCAMLP4LIB) -impl' -impl $<
+grammar/compat5b.cmo: grammar/compat5b.mlp
+	$(OCAMLC) -c -I $(MYCAMLP4LIB) -pp '$(CAMLP4O) -I $(MYCAMLP4LIB) -impl' -impl $<
 else
-$(CHICKEN): $(CHICKENBYTE)
-	cp $< $@
+grammar/compat5.cmo: grammar/compat5.ml
+	$(OCAMLC) -c $<
 endif
 
-$(CHICKENBYTE): checker/check.cma checker/main.ml
-	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(CHKLIBS) $(BYTEFLAGS) $(CUSTOM) -thread -o $@ $(SYSCMA) $^
-
-# coqmktop
-$(COQMKTOP): $(patsubst %.cma,%$(BESTLIB),$(COQMKTOPCMO:.cmo=$(BESTOBJ)))
-	$(SHOW)'OCAMLBEST -o $@'
-	$(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD))
-
-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
-$(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) $(MLINCLUDES) $(BYTEFLAGS) -a -o $@ $^
-
-%.cmxa: | %.mllib.d
-	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -a -o $@ $^
-
-# For the checker, different flags may be used
-
-checker/check.cma: | md5chk checker/check.mllib.d
-	$(SHOW)'OCAMLC -a -o $@'
-	$(HIDE)$(OCAMLC) $(CHKLIBS) $(BYTEFLAGS) -a -o $@ $^
-
-checker/check.cmxa: | md5chk checker/check.mllib.d
-	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(CHKLIBS) $(OPTFLAGS) -a -o $@ $^
-
 ###########################################################################
-# Csdp to micromega special targets
+#  grammar/grammar.cma
 ###########################################################################
 
-plugins/micromega/csdpcert$(EXE): $(CSDPCERTCMO:.cmo=$(BESTOBJ))  \
-		$(addsuffix $(BESTLIB), lib/clib)
-	$(SHOW)'OCAMLBEST -o $@'
-	$(HIDE)$(call bestocaml,,nums unix clib)
-
-###########################################################################
-# CoqIde special targets
-###########################################################################
-
-.PHONY: coqide coqide-binaries coqide-no coqide-byte coqide-opt coqide-files
-
-# target to build CoqIde
-coqide: coqide-files coqide-binaries theories/Init/Prelude.vo
+## In this part, we compile grammar/grammar.cma
+## without relying on .d dependency files, for bootstraping the creation
+## and inclusion of these .d files
 
-COQIDEFLAGS=$(addprefix -I , $(IDESRCDIRS)) $(COQIDEINCLUDES)
+## Explicit dependencies for grammar stuff
 
-.SUFFIXES:.vo
+GRAMBASEDEPS := grammar/gramCompat.cmo grammar/q_util.cmi
+GRAMCMO := grammar/gramCompat.cmo grammar/q_util.cmo \
+ grammar/argextend.cmo grammar/tacextend.cmo grammar/vernacextend.cmo
 
-IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png ide/MacOS/default_accel_map
+grammar/q_util.cmi : grammar/gramCompat.cmo
+grammar/argextend.cmo : $(GRAMBASEDEPS)
+grammar/q_util.cmo : $(GRAMBASEDEPS)
+grammar/tacextend.cmo : $(GRAMBASEDEPS) grammar/argextend.cmo
+grammar/vernacextend.cmo : $(GRAMBASEDEPS) grammar/tacextend.cmo \
+ grammar/argextend.cmo
 
-coqide-binaries: coqide-$(HASCOQIDE) ide-toploop
-coqide-no:
-coqide-byte: $(COQIDEBYTE) $(COQIDE)
-coqide-opt:  $(COQIDEBYTE) $(COQIDE)
-coqide-files: $(IDEFILES)
-ifeq ($(BEST),opt)
-ide-toploop: $(IDETOPLOOPCMA) $(IDETOPLOOPCMA:.cma=.cmxs)
-else
-ide-toploop: $(IDETOPLOOPCMA)
-endif
+## Ocaml compiler with the right options and -I for grammar
 
-ifeq ($(HASCOQIDE),opt)
-$(COQIDE): $(LINKIDEOPT)
-	$(SHOW)'OCAMLOPT -o $@'
-	$(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ unix.cmxa threads.cmxa lablgtk.cmxa \
-		lablgtksourceview2.cmxa str.cmxa $(IDEFLAGS:.cma=.cmxa) $^
-	$(STRIP) $@
-else
-$(COQIDE): $(COQIDEBYTE)
-	cp $< $@
-endif
+GRAMC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) $(CAMLDEBUG) $(USERFLAGS) \
+ -I $(MYCAMLP4LIB) -I grammar
 
-$(COQIDEBYTE): $(LINKIDE)
-	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ unix.cma threads.cma lablgtk.cma \
-	        lablgtksourceview2.cma str.cma $(IDEFLAGS) $(IDECDEPSFLAGS) $^
+## Specific rules for grammar.cma
 
-# install targets
+grammar/grammar.cma : $(GRAMCMO)
+	$(SHOW)'Testing $@'
+	@touch grammar/test.mlp
+	$(HIDE)$(GRAMC) -pp '$(CAMLP4O) -I $(MYCAMLP4LIB) $^ -impl' -impl grammar/test.mlp -o grammar/test
+	@rm -f grammar/test.* grammar/test
+	$(SHOW)'OCAMLC -a $@'   
+	$(HIDE)$(GRAMC) $^ -linkall -a -o $@
 
-.PHONY: install-coqide install-ide-bin install-ide-toploop install-ide-files install-ide-info install-ide-devfiles
+## Support of Camlp5 and Camlp5
 
-ifeq ($(HASCOQIDE),no)
-install-coqide: install-ide-toploop
+ifeq ($(CAMLP4),camlp4)
+ COMPATCMO:=grammar/compat5.cmo grammar/compat5b.cmo
+ GRAMP4USE:=$(COMPATCMO) -D$(CAMLVERSION)
+ GRAMPP:=$(CAMLP4O) -I $(MYCAMLP4LIB) $(GRAMP4USE) $(CAMLP4COMPAT) -impl
 else
-install-coqide: install-ide-bin install-ide-toploop install-ide-files install-ide-info install-ide-devfiles
+ COMPATCMO:=
+ GRAMP4USE:=$(COMPATCMO) pa_extend.cmo q_MLast.cmo pa_macro.cmo -D$(CAMLVERSION)
+ GRAMPP:=$(CAMLP4O) -I $(MYCAMLP4LIB) $(GRAMP4USE) $(CAMLP4COMPAT) -impl
 endif
 
-install-ide-bin:
-	$(MKDIR) $(FULLBINDIR)
-	$(INSTALLBIN) $(COQIDE) $(FULLBINDIR)
-
-install-ide-toploop:
-	$(MKDIR) $(FULLCOQLIB)/toploop
-	$(INSTALLBIN) $(IDETOPLOOPCMA) $(FULLCOQLIB)/toploop/
-ifeq ($(BEST),opt)
-	$(INSTALLBIN) $(IDETOPLOOPCMA:.cma=.cmxs) $(FULLCOQLIB)/toploop/
-endif
+## Rules for standard .mlp and .mli files in grammar/
 
-install-ide-devfiles:
-	$(MKDIR) $(FULLCOQLIB)
-	$(INSTALLSH) $(FULLCOQLIB) $(IDECMA) \
-	  $(foreach lib,$(IDECMA:.cma=_MLLIB_DEPENDENCIES),$(addsuffix .cmi,$($(lib))))
-ifeq ($(BEST),opt)
-	$(INSTALLSH) $(FULLCOQLIB) $(IDECMA:.cma=.cmxa) $(IDECMA:.cma=.a)
-endif
+grammar/%.cmo: grammar/%.mlp | $(COMPATCMO)
+	$(SHOW)'OCAMLC -c -pp $<'
+	$(HIDE)$(GRAMC) -c -pp '$(GRAMPP)' -impl $<
 
-install-ide-files: #Please update $(COQIDEAPP)/Contents/Resources/ at the same time
-	$(MKDIR) $(FULLDATADIR)
-	$(INSTALLLIB) ide/coq.png ide/*.lang ide/coq_style.xml $(FULLDATADIR)
-	$(MKDIR) $(FULLCONFIGDIR)
-	if [ $(IDEINT) = QUARTZ ] ; then $(INSTALLLIB) ide/mac_default_accel_map $(FULLCONFIGDIR)/coqide.keys ; fi
+grammar/%.cmi: grammar/%.mli
+	$(SHOW)'OCAMLC -c $<'
+	$(HIDE)$(GRAMC) -c $<
 
-install-ide-info:
-	$(MKDIR) $(FULLDOCDIR)
-	$(INSTALLLIB) ide/FAQ $(FULLDOCDIR)/FAQ-CoqIde
 
 ###########################################################################
-# CoqIde MacOS special targets
+# Main targets (coqmktop, coqtop.opt, coqtop.byte)
 ###########################################################################
 
-.PHONY: $(COQIDEAPP)/Contents
+.PHONY: coqbinaries
 
-$(COQIDEAPP)/Contents:
-	rm -rdf $@
-	$(MKDIR) $@
-	sed -e "s/VERSION/$(VERSION4MACOS)/g" ide/MacOS/Info.plist.template > $@/Info.plist
-	$(MKDIR) "$@/MacOS"
+coqbinaries: $(COQMKTOP) $(COQTOPEXE) $(COQTOPBYTE) \
+ $(CHICKEN) $(CHICKENBYTE) $(CSDPCERT) $(FAKEIDE)
 
-$(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
+ifeq ($(BEST),opt)
+$(COQTOPEXE): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN) $(TOPLOOPCMA:.cma=.cmxs)
+	$(SHOW)'COQMKTOP -o $@'	
+	$(HIDE)$(COQMKTOP) -boot -opt $(OPTFLAGS) $(LINKMETADATA) -o $@
+	$(STRIP) $@
 	$(CODESIGN) $@
+else
+$(COQTOPEXE): $(COQTOPBYTE)
+	cp $< $@
+endif
 
-###########################################################################
-# tests
-###########################################################################
-
-.PHONY: validate check test-suite $(ALLSTDLIB).v md5chk
-
-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
-
-VALIDOPTS=$(if $(VERBOSE),,-silent) -o -m
-
-validate: $(CHICKEN) | $(ALLVO)
-	$(SHOW)'COQCHK <theories & plugins>'
-	$(HIDE)$(CHICKEN) -boot $(VALIDOPTS) $(ALLMODS)
-
-$(ALLSTDLIB).v:
-	$(SHOW)'MAKE $(notdir $@)'
-	$(HIDE)echo "Require $(ALLMODS)." > $@
-
-MAKE_TSOPTS=-C test-suite -s VERBOSE=$(VERBOSE)
-
-check: validate test-suite
-
-test-suite: world $(ALLSTDLIB).v
-	$(MAKE) $(MAKE_TSOPTS) clean
-	$(MAKE) $(MAKE_TSOPTS) all
-	$(MAKE) $(MAKE_TSOPTS) report
-
-##################################################################
-# partial targets: 1) core ML parts
-##################################################################
-
-.PHONY: lib kernel byterun library proofs tactics interp parsing pretyping
-.PHONY: highparsing stm toplevel hightactics
-
-lib: lib/clib.cma lib/lib.cma
-kernel: kernel/kernel.cma
-byterun: $(BYTERUN)
-library: library/library.cma
-proofs: proofs/proofs.cma
-tactics: tactics/tactics.cma
-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
-
-###########################################################################
-# 2) theories and plugins files
-###########################################################################
-
-.PHONY: init theories theories-light
-.PHONY: logic arith bool narith zarith qarith lists strings sets
-.PHONY: fsets relations wellfounded reals setoids sorting numbers noreal
-.PHONY: msets mmaps compat
-
-init: $(INITVO)
+$(COQTOPBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) $(TOPLOOPCMA)
+	$(SHOW)'COQMKTOP -o $@'	
+	$(HIDE)$(COQMKTOP) -boot -top $(BYTEFLAGS) -o $@
 
-theories: $(THEORIESVO)
-theories-light: $(THEORIESLIGHTVO)
-
-logic: $(LOGICVO)
-arith: $(ARITHVO)
-bool: $(BOOLVO)
-narith: $(NARITHVO)
-zarith: $(ZARITHVO)
-qarith: $(QARITHVO)
-lists: $(LISTSVO)
-strings: $(STRINGSVO)
-sets: $(SETSVO)
-fsets: $(FSETSVO)
-relations: $(RELATIONSVO)
-wellfounded: $(WELLFOUNDEDVO)
-reals: $(REALSVO)
-setoids: $(SETOIDSVO)
-sorting: $(SORTINGVO)
-numbers: $(NUMBERSVO)
-unicode: $(UNICODEVO)
-classes: $(CLASSESVO)
-program: $(PROGRAMVO)
-structures: $(STRUCTURESVO)
-vectors: $(VECTORSVO)
-msets: $(MSETSVO)
-compat: $(COMPATVO)
-
-noreal: unicode logic arith bool zarith qarith lists sets fsets \
-	relations wellfounded setoids sorting
+# coqmktop
 
-###########################################################################
-# 3) plugins
-###########################################################################
+COQMKTOPCMO:=lib/clib.cma lib/cErrors.cmo tools/tolink.cmo tools/coqmktop.cmo
 
-.PHONY: plugins omega micromega setoid_ring nsatz extraction
-.PHONY: fourier funind cc rtauto btauto pluginsopt pluginsbyte
+$(COQMKTOP): $(call bestobj, $(COQMKTOPCMO))
+	$(SHOW)'OCAMLBEST -o $@'
+	$(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD))
 
-plugins: $(PLUGINSVO)
-omega: $(OMEGAVO) $(OMEGACMA) $(ROMEGAVO) $(ROMEGACMA)
-micromega: $(MICROMEGAVO) $(MICROMEGACMA) $(CSDPCERT)
-setoid_ring: $(RINGVO) $(RINGCMA)
-nsatz: $(NSATZVO) $(NSATZCMA)
-extraction: $(EXTRACTIONCMA)
-fourier: $(FOURIERVO) $(FOURIERCMA)
-funind: $(FUNINDCMA) $(FUNINDVO)
-cc: $(CCVO) $(CCCMA)
-rtauto: $(RTAUTOVO) $(RTAUTOCMA)
-btauto: $(BTAUTOVO) $(BTAUTOCMA)
-
-pluginsopt: $(PLUGINSOPT)
-pluginsbyte: $(PLUGINS)
+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)"\"" >> $@
 
-###########################################################################
-# rules to make theories and plugins
-###########################################################################
+# coqc
 
-theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) | theories/Init/%.v.d
-	$(SHOW)'COQC $(COQ_XML) -noinit $<'
-	$(HIDE)rm -f theories/Init/$*.glob
-	$(HIDE)$(BOOTCOQC) $< $(COQ_XML) -noinit -R theories Coq
+COQCCMO:=lib/clib.cma lib/cErrors.cmo toplevel/usage.cmo tools/coqc.cmo
 
-theories/Numbers/Natural/BigN/NMake_gen.v: theories/Numbers/Natural/BigN/NMake_gen.ml
-	$(OCAML) $< $(TOTARGET)
+$(COQC): $(call bestobj, $(COQCCMO))
+	$(SHOW)'OCAMLBEST -o $@'
+	$(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD))
 
 ###########################################################################
-# tools
+# other tools
 ###########################################################################
 
-.PHONY: printers tools
-
-printers: $(DEBUGPRINTERS)
-
-tools: $(TOOLS) $(DEBUGPRINTERS) $(COQDEPBOOT)
+.PHONY: tools
+tools: $(TOOLS) $(OCAMLLIBDEP) $(COQDEPBOOT)
 
 # coqdep_boot : a basic version of coqdep, with almost no dependencies.
+# We state these dependencies here explicitly, since some .ml.d files
+# may still be missing or not taken in account yet by make when coqdep_boot
+# is being built.
 
-# Here it is important to mention .ml files instead of .cmo in order
-# to avoid using implicit rules and hence .ml.d files that would need
-# coqdep_boot.
+COQDEPBOOTSRC := lib/minisys.cmo \
+ tools/coqdep_lexer.cmo tools/coqdep_common.cmo tools/coqdep_boot.cmo
 
-COQDEPBOOTSRC:= \
-  tools/coqdep_lexer.mli tools/coqdep_lexer.ml \
-  tools/coqdep_common.mli tools/coqdep_common.ml \
-  tools/coqdep_boot.ml
+tools/coqdep_lexer.cmo : tools/coqdep_lexer.cmi
+tools/coqdep_lexer.cmx : tools/coqdep_lexer.cmi
+tools/coqdep_common.cmo : lib/minisys.cmo tools/coqdep_lexer.cmi tools/coqdep_common.cmi
+tools/coqdep_common.cmx : lib/minisys.cmx tools/coqdep_lexer.cmx tools/coqdep_common.cmi
+tools/coqdep_boot.cmo : tools/coqdep_common.cmi
+tools/coqdep_boot.cmx : tools/coqdep_common.cmx
 
-$(COQDEPBOOT): $(COQDEPBOOTSRC)
+$(COQDEPBOOT): $(call bestobj, $(COQDEPBOOTSRC))
 	$(SHOW)'OCAMLBEST -o $@'
 	$(HIDE)$(call bestocaml, -I tools, unix)
 
-# the full coqdep
+$(OCAMLLIBDEP): $(call bestobj, tools/ocamllibdep.cmo)
+	$(SHOW)'OCAMLBEST -o $@'
+	$(HIDE)$(call bestocaml, -I tools, unix)
 
-$(COQDEP): $(patsubst %.cma,%$(BESTLIB),$(COQDEPCMO:.cmo=$(BESTOBJ)))
+# The full coqdep (unused by this build, but distributed by make install)
+
+COQDEPCMO:=lib/clib.cma lib/cErrors.cmo lib/cWarnings.cmo lib/minisys.cmo \
+  lib/system.cmo tools/coqdep_lexer.cmo tools/coqdep_common.cmo \
+  tools/coqdep.cmo
+
+$(COQDEP): $(call bestobj, $(COQDEPCMO))
 	$(SHOW)'OCAMLBEST -o $@'
 	$(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD))
 
-$(GALLINA): $(addsuffix $(BESTOBJ), tools/gallina_lexer tools/gallina)
+$(GALLINA): $(call bestobj, tools/gallina_lexer.cmo tools/gallina.cmo)
 	$(SHOW)'OCAMLBEST -o $@'
 	$(HIDE)$(call bestocaml,,)
 
-$(COQMAKEFILE):  $(patsubst %.cma,%$(BESTLIB),$(COQMAKEFILECMO:.cmo=$(BESTOBJ)))
+COQMAKEFILECMO:=lib/clib.cma ide/project_file.cmo tools/coq_makefile.cmo
+
+$(COQMAKEFILE): $(call bestobj,$(COQMAKEFILECMO))
 	$(SHOW)'OCAMLBEST -o $@'
 	$(HIDE)$(call bestocaml,,str unix threads)
 
-$(COQTEX): tools/coq_tex$(BESTOBJ)
+$(COQTEX): $(call bestobj, tools/coq_tex.cmo)
 	$(SHOW)'OCAMLBEST -o $@'
 	$(HIDE)$(call bestocaml,,str)
 
-$(COQWC): tools/coqwc$(BESTOBJ)
+$(COQWC): $(call bestobj, tools/coqwc.cmo)
 	$(SHOW)'OCAMLBEST -o $@'
 	$(HIDE)$(call bestocaml,,)
 
-$(COQDOC): $(patsubst %.cma,%$(BESTLIB),$(COQDOCCMO:.cmo=$(BESTOBJ)))
+COQDOCCMO:=lib/clib.cma $(addprefix tools/coqdoc/, \
+  cdglobals.cmo alpha.cmo index.cmo tokens.cmo output.cmo cpretty.cmo main.cmo )
+
+$(COQDOC): $(call bestobj, $(COQDOCCMO))
 	$(SHOW)'OCAMLBEST -o $@'
 	$(HIDE)$(call bestocaml,,str unix)
 
-$(COQWORKMGR): $(addsuffix $(BESTOBJ), stm/coqworkmgrApi tools/coqworkmgr) \
-		$(addsuffix $(BESTLIB), lib/clib)
+$(COQWORKMGR): $(call bestobj, lib/clib.cma stm/coqworkmgrApi.cmo tools/coqworkmgr.cmo)
 	$(SHOW)'OCAMLBEST -o $@'
-	$(HIDE)$(call bestocaml,, $(SYSMOD) clib)
+	$(HIDE)$(call bestocaml,, $(SYSMOD))
 
 # fake_ide : for debugging or test-suite purpose, a fake ide simulating
 # a connection to coqtop -ideslave
 
-$(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))
+FAKEIDECMO:= lib/clib.cma lib/cErrors.cmo lib/spawn.cmo ide/document.cmo \
+ ide/serialize.cmo ide/xml_lexer.cmo ide/xml_parser.cmo ide/xml_printer.cmo \
+ ide/xmlprotocol.cmo tools/fake_ide.cmo
+
+$(FAKEIDE): $(call bestobj, $(FAKEIDECMO)) | $(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/analyze$(BESTOBJ) checker/values$(BESTOBJ) checker/votour.ml
+bin/votour: $(call bestobj, lib/cObj.cmo checker/analyze.cmo checker/values.cmo checker/votour.cmo)
 	$(SHOW)'OCAMLBEST -o $@'
 	$(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) $(CAMLP4FLAGS) -impl' -impl $<
-tools/compat5b.cmo: tools/compat5b.mlp
-	$(OCAMLC) -c -I $(MYCAMLP4LIB) -pp '$(CAMLP4O) $(CAMLP4FLAGS) -impl' -impl $<
-else
-tools/compat5.cmo: tools/compat5.ml
-	$(OCAMLC) -c $<
-tools/compat5b.cmo: tools/compat5b.ml
-	$(OCAMLC) -c $<
-endif
-
 ###########################################################################
-# Documentation : cf Makefile.doc
+# Csdp to micromega special targets
 ###########################################################################
 
-documentation: doc-$(WITHDOC)
-doc-all: doc
-doc-no:
+CSDPCERTCMO:=lib/clib.cma $(addprefix plugins/micromega/, \
+  mutils.cmo 	micromega.cmo \
+  sos_types.cmo sos_lib.cmo sos.cmo 	csdpcert.cmo )
 
-.PHONY: documentation doc-all doc-no
+$(CSDPCERT): $(call bestobj, $(CSDPCERTCMO))
+	$(SHOW)'OCAMLBEST -o $@'
+	$(HIDE)$(call bestocaml,,nums unix)
 
 ###########################################################################
-# Installation
+# tests
 ###########################################################################
 
-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=
-
-  # Can be changed for a local installation (to make packages).
-  # You must NOT put a "/" at the end (Cygnus for win32 does not like "//").
-
-ifdef COQINSTALLPREFIX
-FULLBINDIR=$(BINDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
-FULLCOQLIB=$(COQLIBINSTALL:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
-FULLCONFIGDIR=$(CONFIGDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
-FULLDATADIR=$(DATADIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
-FULLMANDIR=$(MANDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
-FULLEMACSLIB=$(EMACSLIB:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
-FULLCOQDOCDIR=$(COQDOCDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
-FULLDOCDIR=$(DOCDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
-else
-FULLBINDIR=$(BINDIR)
-FULLCOQLIB=$(COQLIBINSTALL)
-FULLCONFIGDIR=$(CONFIGDIR)
-FULLDATADIR=$(DATADIR)
-FULLMANDIR=$(MANDIR)
-FULLEMACSLIB=$(EMACSLIB)
-FULLCOQDOCDIR=$(COQDOCDIR)
-FULLDOCDIR=$(DOCDIR)
-endif
-
-.PHONY: install-coq install-coqlight install-binaries install-byte install-opt
-.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-devfiles
-install-coqlight: install-binaries install-library-light
+.PHONY: validate check test-suite $(ALLSTDLIB).v
 
-install-binaries: install-tools
-	$(MKDIR) $(FULLBINDIR)
-	$(INSTALLBIN) $(COQC) $(COQTOPBYTE) $(COQTOPEXE) $(CHICKEN) $(FULLBINDIR)
-	$(MKDIR) $(FULLCOQLIB)/toploop
-	$(INSTALLBIN) $(TOPLOOPCMA) $(FULLCOQLIB)/toploop/
-ifeq ($(BEST),opt)
-	$(INSTALLBIN) $(TOPLOOPCMA:.cma=.cmxs) $(FULLCOQLIB)/toploop/
-endif
-
-
-install-tools:
-	$(MKDIR) $(FULLBINDIR)
-	# recopie des fichiers de style pour coqide
-	$(MKDIR) $(FULLCOQLIB)/tools/coqdoc
-	touch $(FULLCOQLIB)/tools/coqdoc/coqdoc.sty $(FULLCOQLIB)/tools/coqdoc/coqdoc.css # to have the mode according to umask (bug #1715)
-	$(INSTALLLIB) tools/coqdoc/coqdoc.css tools/coqdoc/coqdoc.sty $(FULLCOQLIB)/tools/coqdoc
-	$(INSTALLBIN) $(TOOLS) $(FULLBINDIR)
-
-# The list of .cmi to install, including the ones obtained
-# from .mli without .ml, and the ones obtained from .ml without .mli
-
-INSTALLCMI = $(sort \
-	$(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)/user-contrib
-ifndef CUSTOM
-	$(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB)
-endif
-ifeq ($(BEST),opt)
-	$(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB)
-	$(INSTALLSH) $(FULLCOQLIB) $(PLUGINSOPT)
-endif
-# csdpcert is not meant to be directly called by the user; we install
-# it with libraries
-	-$(MKDIR) $(FULLCOQLIB)/plugins/micromega
-	$(INSTALLBIN) $(CSDPCERT) $(FULLCOQLIB)/plugins/micromega
-	rm -f $(FULLCOQLIB)/revision
-	-$(INSTALLLIB) revision $(FULLCOQLIB)
-
-install-library-light:
-	$(MKDIR) $(FULLCOQLIB)
-	$(INSTALLSH) $(FULLCOQLIB) $(LIBFILESLIGHT) $(INITPLUGINS)
-	rm -f $(FULLCOQLIB)/revision
-	-$(INSTALLLIB) revision $(FULLCOQLIB)
-ifndef CUSTOM
-	$(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB)
-endif
-ifeq ($(BEST),opt)
-	$(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB)
-	$(INSTALLSH)  $(FULLCOQLIB) $(INITPLUGINSOPT)
-endif
+VALIDOPTS=$(if $(VERBOSE),,-silent) -o -m
 
-install-coq-info: install-coq-manpages install-emacs install-latex
+validate: $(CHICKEN) | $(ALLVO)
+	$(SHOW)'COQCHK <theories & plugins>'
+	$(HIDE)$(CHICKEN) -boot $(VALIDOPTS) $(ALLMODS)
 
-install-coq-manpages:
-	$(MKDIR) $(FULLMANDIR)/man1
-	$(INSTALLLIB) $(MANPAGES) $(FULLMANDIR)/man1
+$(ALLSTDLIB).v:
+	$(SHOW)'MAKE $(notdir $@)'
+	$(HIDE)echo "Require $(ALLMODS)." > $@
 
-install-emacs:
-	$(MKDIR) $(FULLEMACSLIB)
-	$(INSTALLLIB) tools/gallina-db.el tools/coq-font-lock.el tools/gallina-syntax.el tools/gallina.el tools/coq-inferior.el $(FULLEMACSLIB)
+MAKE_TSOPTS=-C test-suite -s VERBOSE=$(VERBOSE)
 
-# command to update TeX' kpathsea database
-#UPDATETEX = $(MKTEXLSR) /usr/share/texmf /var/spool/texmf $(BASETEXDIR) > /dev/null
+check: validate test-suite
 
-install-latex:
-	$(MKDIR) $(FULLCOQDOCDIR)
-	$(INSTALLLIB) tools/coqdoc/coqdoc.sty $(FULLCOQDOCDIR)	
-#	-$(UPDATETEX)
+test-suite: world $(ALLSTDLIB).v
+	$(MAKE) $(MAKE_TSOPTS) clean
+	$(MAKE) $(MAKE_TSOPTS) all
+	$(MAKE) $(MAKE_TSOPTS) report
 
 ###########################################################################
-# Documentation of the source code (using ocamldoc)
+# Default rules for compiling ML code
 ###########################################################################
 
-.PHONY: source-doc mli-doc ml-doc
-
-source-doc: mli-doc $(OCAMLDOCDIR)/coq.pdf
-
-$(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 +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
+# Target for libraries .cma and .cmxa
 
-%_dep.png: %.dot
-	$(DOT) -Tpng $< -o $@
+# The dependency over the .mllib is somewhat artificial, since
+# ocamlc -a won't use this file, hence the $(filter-out ...) below.
+# But this ensures that the .cm(x)a is rebuilt when needed,
+# (especially when removing a module in the .mllib).
+# We used to have a "order-only" dependency over .mllib.d here,
+# but the -include mechanism should already ensure that we have
+# up-to-date dependencies.
 
-%_types.dot: %.mli
-	$(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -dot-types -o $@ $< 
-
-OCAMLDOC_MLLIBD = $(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ \
-  $(foreach lib,$(|:.mllib.d=_MLLIB_DEPENDENCIES),$(addsuffix .ml,$($(lib))))
-
-%.dot: | %.mllib.d
-	$(OCAMLDOC_MLLIBD)
-
-ml-doc:
-	$(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)
-
-%.dot: %.mli
-	$(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $< 
-
-$(OCAMLDOCDIR)/%.pdf: $(OCAMLDOCDIR)/%.tex
-	(cd $(OCAMLDOCDIR) ; pdflatex $*.tex && pdflatex $*.tex)
-
-###########################################################################
-### Special rules
-###########################################################################
+%.cma: %.mllib
+	$(SHOW)'OCAMLC -a -o $@'
+	$(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^)
 
-dev/printers.cma: | dev/printers.mllib.d
-	$(SHOW)'Testing $@'
-	$(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -thread $(SYSCMA) $(P4CMA) $^ -o test-printer
-	@rm -f test-printer
-	$(SHOW)'OCAMLC -a $@'   
-	$(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -thread $(SYSCMA) $(P4CMA) $^ -linkall -a -o $@
+%.cmxa: %.mllib
+	$(SHOW)'OCAMLOPT -a -o $@'
+	$(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -a -o $@ $(filter-out %.mllib, $^)
 
-grammar/grammar.cma: | grammar/grammar.mllib.d
-	$(SHOW)'Testing $@'
-	@touch test.ml4
-	$(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) $(MLINCLUDES) $(BYTEFLAGS) $^ -linkall -a -o $@
+# For plugin packs
 
-ide/coqide_main.ml: ide/coqide_main.ml4 config/Makefile # no camlp4deps here
-	$(SHOW)'CAMLP4O   $<'
-	$(HIDE)$(CAMLP4O) $(CAMLP4FLAGS) $(PR_O) $(CAMLP4USE) -D$(IDEINT) -impl $< -o $@
-
-# pretty printing of the revision number when compiling a checked out
-# source tree
-.PHONY: revision
-
-revision:
-	$(SHOW)'CHECK revision'
-	$(HIDE)rm -f revision.new
-ifeq ($(CHECKEDOUT),svn)
-	$(HIDE)set -e; \
-        if test -x "`which svn`"; then \
-	  export LC_ALL=C;\
-	  svn info . | sed -ne '/URL/s/.*\/\([^\/]\{1,\}\)/\1/p' > revision.new; \
-	  svn info . | sed -ne '/Revision/s/Revision: \([0-9]\{1,\}\)/\1/p'>> revision.new; \
-	fi
-endif
-ifeq ($(CHECKEDOUT),gnuarch)
-	$(HIDE)set -e; \
-        if test -x "`which tla`"; then \
-	  LANG=C; export LANG; \
-	  tla tree-version  >  revision.new ; \
-	  tla tree-revision | sed -ne 's|.*--||p' >> revision.new ; \
-	fi
-endif
-ifeq ($(CHECKEDOUT),git)
-	$(HIDE)set -e; \
-	if test -x "`which git`"; then \
-	  LANG=C; export LANG; \
-	  GIT_BRANCH=$$(git branch -a | sed -ne '/^\* /s/^\* \(.*\)/\1/p'); \
-	  GIT_HOST=$$(hostname); \
-	  GIT_PATH=$$(pwd); \
-	  (echo "$${GIT_HOST}:$${GIT_PATH},$${GIT_BRANCH}") > revision.new; \
-	  (echo "$$(git log -1 --pretty='format:%H')") >> revision.new; \
-	fi
-endif
-	$(HIDE)set -e; \
-	if test -e revision.new; then \
-          if test -e revision; then \
-	    if test "`cat revision`" = "`cat revision.new`" ; then \
-	       rm -f revision.new; \
-            else \
-               mv -f revision.new revision; \
-            fi; \
-          else \
-            mv -f revision.new revision; \
-          fi \
-	fi
+# Note: both ocamlc -pack and ocamlopt -pack will create the same .cmi, and there's
+# apparently no way to avoid that (no -intf-suffix hack as below).
+# We at least ensure that these two commands won't run at the same time, by a fake
+# dependency from the packed .cmx to the packed .cmo.
 
-###########################################################################
-# Default rules
-###########################################################################
+%.cmo: %.mlpack
+	$(SHOW)'OCAMLC -pack -o $@'
+	$(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -pack -o $@ $(filter-out %.mlpack, $^)
 
-## Three flavor of flags: checker/* ide/* and normal files
+%.cmx: %.mlpack %.cmo
+	$(SHOW)'OCAMLOPT -pack -o $@'
+	$(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -pack -o $@ $(filter-out %.mlpack %.cmo, $^)
 
 COND_BYTEFLAGS= \
- $(if $(filter checker/%,$<), $(CHKLIBS) -thread, \
-   $(if $(filter ide/%,$<), $(COQIDEFLAGS), \
-     $(if $(filter tools/fake_ide% tools/coq_makefile%,$<), -I ide,) $(MLINCLUDES) -thread)) $(BYTEFLAGS)
+ $(if $(filter tools/fake_ide% tools/coq_makefile%,$<), -I ide,) $(MLINCLUDES) $(BYTEFLAGS)
 
 COND_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 $@
+ $(if $(filter tools/fake_ide% tools/coq_makefile%,$<), -I ide,) $(MLINCLUDES) $(OPTFLAGS)
 
-%.cmi: %.mli | %.mli.d
+%.cmi: %.mli
 	$(SHOW)'OCAMLC    $<'
 	$(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $<
 
-%.cmo: %.ml | %.ml.d
+%.cmo: %.ml
 	$(SHOW)'OCAMLC    $<'
 	$(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $<
 
@@ -998,125 +563,120 @@ $(MLWITHOUTMLI:.ml=.cmx): %.cmx: %.cmi  # for .ml with .mli this is already the
 
 $(MLWITHOUTMLI:.ml=.cmi): %.cmi: %.cmo
 
-%.cmx: %.ml | %.ml.d
+# NB: the *_FORPACK variables are generated in *.mlpack.d by ocamllibdep
+# The only exceptions are the sources of the csdpcert binary.
+# To avoid warnings, we set them manually here:
+plugins/micromega/sos_lib_FORPACK:=
+plugins/micromega/sos_FORPACK:=
+plugins/micromega/sos_print_FORPACK:=
+plugins/micromega/csdpcert_FORPACK:=
+
+plugins/%.cmx: plugins/%.ml
 	$(SHOW)'OCAMLOPT  $<'
-	$(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) -c $<
+	$(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -c $<
 
-%.cmxs: %.cmxa
-	$(SHOW)'OCAMLOPT -shared -o $@'
-ifeq ($(HASNATDYNLINK),os5fixme)
-	$(HIDE)dev/ocamlopt_shared_os5fix.sh "$(OCAMLOPT)" $@
-else
-	$(HIDE)$(OCAMLOPT) -linkall -shared -o $@ $<
-endif
+%.cmx: %.ml
+	$(SHOW)'OCAMLOPT  $<'
+	$(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) -c $<
 
 %.cmxs: %.cmx
 	$(SHOW)'OCAMLOPT -shared -o $@'
 	$(HIDE)$(OCAMLOPT) -shared -o $@ $<
 
+%.cmxs: %.cmxa
+	$(SHOW)'OCAMLOPT -shared -o $@'
+	$(HIDE)$(OCAMLOPT) -linkall -shared -o $@ $<
+
 %.ml: %.mll
 	$(SHOW)'OCAMLLEX  $<'
 	$(HIDE)$(OCAMLLEX) -o $@ "$*.mll"
 
-%.ml %.mli: %.mly
-	$(SHOW)'OCAMLYACC $<'
-	$(HIDE)$(OCAMLYACC) $<
-
-plugins/%_mod.ml: plugins/%.mllib
-	$(SHOW)'ECHO... > $@'
-	$(HIDE)sed -e "s/\([^ ]\{1,\}\)/let _=Mltop.add_known_module\"\1\" /g" $< > $@
-	$(HIDE)echo "let _=Mltop.add_known_module\"$(notdir $*)\"" >> $@
-
-# NB: compatibility modules for camlp4: 
-# - tools/compat5.cmo changes GEXTEND into EXTEND. Safe, always loaded
-# - tools/compat5b.cmo changes EXTEND into EXTEND Gram. Interact badly with
-#    syntax such that VERNAC EXTEND, we only load it for a few files via camlp4deps
-
-%.ml: %.ml4 | %.ml4.d tools/compat5.cmo tools/compat5b.cmo
+%.ml: %.ml4 | $(CAMLP4DEPS)
 	$(SHOW)'CAMLP4O   $<'
-	$(HIDE)$(CAMLP4O) $(CAMLP4FLAGS) $(PR_O) tools/compat5.cmo \
-	  $(call CAMLP4DEPS,$<) $(CAMLP4USE) $(CAMLP4COMPAT) -impl $< -o $@
+	$(HIDE)$(CAMLP4O) -I $(MYCAMLP4LIB) $(PR_O) \
+	  $(CAMLP4DEPS) $(CAMLP4USE) $(CAMLP4COMPAT) -impl $< -o $@
 
-%.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)$(CHICKEN) -boot -silent -norec $(call vo_to_mod,$@) \
-	  || ( RV=$$?; rm -f "$@"; exit $${RV} )
-endif
 
 ###########################################################################
-# Dependencies
+# Dependencies of ML code
 ###########################################################################
 
-# .ml4.d contains the dependencies to generate the .ml from the .ml4
-# NOT to generate object code.
+# Ocamldep is now used directly again (thanks to -ml-synonym in OCaml >= 3.12)
+OCAMLDEP = $(OCAMLFIND) ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack
 
-%.ml4.d: $(D_DEPEND_BEFORE_SRC) %.ml4
-	$(SHOW)'CAMLP4DEPS $<'
-	$(HIDE)echo "$*.ml: $(if $(NO_RECOMPILE_ML4),$(ORDER_ONLY_SEP)) $(call CAMLP4DEPS,$<)" $(TOTARGET)
+%.ml.d: $(D_DEPEND_BEFORE_SRC) %.ml $(D_DEPEND_AFTER_SRC) $(GENFILES)
+	$(SHOW)'OCAMLDEP  $<'
+	$(HIDE)$(OCAMLDEP) $(DEPFLAGS) "$<" $(TOTARGET)
 
-# Since OCaml 3.12.1, we could use again ocamldep directly, thanks to
-# the option -ml-synonym
+%.mli.d: $(D_DEPEND_BEFORE_SRC) %.mli $(D_DEPEND_AFTER_SRC) $(GENFILES)
+	$(SHOW)'OCAMLDEP  $<'
+	$(HIDE)$(OCAMLDEP) $(DEPFLAGS) "$<" $(TOTARGET)
 
-OCAMLDEP_NG = $(OCAMLDEP) -slash -ml-synonym .ml4
+%.mllib.d: $(D_DEPEND_BEFORE_SRC) %.mllib $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES)
+	$(SHOW)'OCAMLLIBDEP  $<'
+	$(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) "$<" $(TOTARGET)
 
-checker/%.ml.d: $(D_DEPEND_BEFORE_SRC) checker/%.ml $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
-	$(SHOW)'OCAMLDEP  $<'
-	$(HIDE)$(OCAMLDEP_NG) $(LOCALCHKLIBS) "$<" $(TOTARGET)
+%.mlpack.d: $(D_DEPEND_BEFORE_SRC) %.mlpack $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES)
+	$(SHOW)'OCAMLLIBDEP  $<'
+	$(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) "$<" $(TOTARGET)
 
-checker/%.mli.d: $(D_DEPEND_BEFORE_SRC) checker/%.mli $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
-	$(SHOW)'OCAMLDEP  $<'
-	$(HIDE)$(OCAMLDEP_NG) $(LOCALCHKLIBS) "$<" $(TOTARGET)
+###########################################################################
+# Compilation of .v files
+###########################################################################
 
-%.ml.d: $(D_DEPEND_BEFORE_SRC) %.ml $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
-	$(SHOW)'OCAMLDEP  $<'
-	$(HIDE)$(OCAMLDEP_NG) $(DEPFLAGS) "$<" $(TOTARGET)
+# NB: for make world, no need to mention explicitly the .cmxs of the plugins,
+# since they are all mentioned in at least one Declare ML Module in some .v
 
-%.mli.d: $(D_DEPEND_BEFORE_SRC) %.mli $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
-	$(SHOW)'OCAMLDEP  $<'
-	$(HIDE)$(OCAMLDEP_NG) $(DEPFLAGS) "$<" $(TOTARGET)
+coqlib: theories plugins
 
-checker/%.mllib.d: $(D_DEPEND_BEFORE_SRC) checker/%.mllib $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
-	$(SHOW)'COQDEP  $<'
-	$(HIDE)$(COQDEPBOOT) -I checker -c "$<" $(TOTARGET)
+theories: $(THEORIESVO)
+plugins: $(PLUGINSVO)
 
-%.mllib.d: $(D_DEPEND_BEFORE_SRC) %.mllib $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
-	$(SHOW)'COQDEP  $<'
-	$(HIDE)$(COQDEPBOOT) -I kernel -I tools/coqdoc -c "$<" $(TOTARGET)
+.PHONY: coqlib theories plugins
 
-%.v.d: $(D_DEPEND_BEFORE_SRC) %.v $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENVFILES)
-	$(SHOW)'COQDEP    $<'
-	$(HIDE)$(COQDEPBOOT) $(DEPNATDYN) "$<" $(TOTARGET)
+# One of the .v files is macro-generated
 
-%_stubs.c.d: $(D_DEPEND_BEFORE_SRC) %_stubs.c $(D_DEPEND_AFTER_SRC)
-	$(SHOW)'CCDEP	$<'
-	$(HIDE)echo "$@ $(@:.c.d=.o): $(@:.c.d=.c)" > $@
+theories/Numbers/Natural/BigN/NMake_gen.v: theories/Numbers/Natural/BigN/NMake_gen.ml
+	$(OCAML) $< $(TOTARGET)
 
-%.c.d: $(D_DEPEND_BEFORE_SRC) %.c $(D_DEPEND_AFTER_SRC) $(GENHFILES)
-	$(SHOW)'CCDEP     $<'
-	$(HIDE)$(OCAMLC) -ccopt "-MM -MQ $@ -MQ $(<:.c=.o) -isystem $(CAMLHLIB)" $< $(TOTARGET)
+# The .vo files in Init are built with the -noinit option
 
-###########################################################################
-# this sets up developper supporting stuff
-###########################################################################
+theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP)
+	$(SHOW)'COQC $(COQ_XML) -noinit $<'
+	$(HIDE)rm -f theories/Init/$*.glob
+	$(HIDE)$(BOOTCOQC) $< $(COQ_XML) -noinit -R theories Coq
 
-.PHONY: devel otags
-devel: $(DEBUGPRINTERS)
+# The general rule for building .vo files :
 
-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)
+%.vo %.glob: %.v theories/Init/Prelude.vo $(VO_TOOLS_DEP)
+	$(SHOW)'COQC      $<'
+	$(HIDE)rm -f $*.glob
+	$(HIDE)$(BOOTCOQC) $<
+ifdef VALIDATE
+	$(SHOW)'COQCHK    $(call vo_to_mod,$@)'
+	$(HIDE)$(CHICKEN) -boot -silent -norec $(call vo_to_mod,$@) \
+	  || ( RV=$$?; rm -f "$@"; exit $${RV} )
+endif
 
+# Dependencies of .v files
+
+%.v.d: $(D_DEPEND_BEFORE_SRC) %.v $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENVFILES)
+	$(SHOW)'COQDEP    $<'
+	$(HIDE)$(COQDEPBOOT) -boot $(DEPNATDYN) "$<" $(TOTARGET)
 
 ###########################################################################
 
 # To speed-up things a bit, let's dissuade make to attempt rebuilding makefiles
 
-Makefile Makefile.build Makefile.common config/Makefile : ;
+Makefile $(wildcard Makefile.*) config/Makefile : ;
+
+# Final catch-all rule.
+# Usually, 'make' would display such an error itself.
+# But if the target has some declared dependencies (e.g. in a .d)
+# but no building rule, 'make' succeeds silently (see bug #4812).
 
+%:
+	@echo "Error: no rule to make target $@ (or missing .PHONY)" && false
 
 # For emacs: 
 # Local Variables: 
diff --git a/Makefile.checker b/Makefile.checker
new file mode 100644
index 00000000..3ea0bace
--- /dev/null
+++ b/Makefile.checker
@@ -0,0 +1,86 @@
+#######################################################################
+#  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       #
+#######################################################################
+
+## Makefile rules for building Coqchk
+
+## NB: For the moment, the build system of Coqchk is part of
+## the one of Coq. In particular, this Makefile.checker is included in
+## Makefile.build. Please ensure that the rules define here are
+## indeed specific to files of the form checker/*
+
+# The binaries
+
+CHICKENBYTE:=bin/coqchk.byte$(EXE)
+CHICKEN:=bin/coqchk$(EXE)
+
+# The sources
+
+CHKLIBS:= -I config -I lib -I checker
+
+## NB: currently, both $(OPTFLAGS) and $(BYTEFLAGS) contain -thread
+
+# The rules
+
+ifeq ($(BEST),opt)
+$(CHICKEN): checker/check.cmxa checker/main.ml
+	$(SHOW)'OCAMLOPT -o $@'
+	$(HIDE)$(OCAMLOPT) $(SYSCMXA) $(CHKLIBS) $(OPTFLAGS) $(LINKMETADATA) -o $@ $^
+	$(STRIP) $@
+	$(CODESIGN) $@
+else
+$(CHICKEN): $(CHICKENBYTE)
+	cp $< $@
+endif
+
+$(CHICKENBYTE): checker/check.cma checker/main.ml
+	$(SHOW)'OCAMLC -o $@'
+	$(HIDE)$(OCAMLC) $(SYSCMA) $(CHKLIBS) $(BYTEFLAGS) $(CUSTOM) -o $@ $^
+
+checker/check.cma: checker/check.mllib | md5chk
+	$(SHOW)'OCAMLC -a -o $@'
+	$(HIDE)$(OCAMLC) $(CHKLIBS) $(BYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^)
+
+checker/check.cmxa: checker/check.mllib | md5chk
+	$(SHOW)'OCAMLOPT -a -o $@'
+	$(HIDE)$(OCAMLOPT) $(CHKLIBS) $(OPTFLAGS) -a -o $@ $(filter-out %.mllib, $^)
+
+checker/%.ml.d: checker/%.ml
+	$(SHOW)'OCAMLDEP  $<'
+	$(HIDE)$(OCAMLFIND) ocamldep -slash $(CHKLIBS) "$<" $(TOTARGET)
+
+checker/%.mli.d: checker/%.mli
+	$(SHOW)'OCAMLDEP  $<'
+	$(HIDE)$(OCAMLFIND) ocamldep -slash $(CHKLIBS) "$<" $(TOTARGET)
+
+checker/%.mllib.d: checker/%.mllib | $(OCAMLLIBDEP)
+	$(SHOW)'OCAMLLIBDEP  $<'
+	$(HIDE)$(OCAMLLIBDEP) $(CHKLIBS) "$<" $(TOTARGET)
+
+checker/%.cmi: checker/%.mli
+	$(SHOW)'OCAMLC    $<'
+	$(HIDE)$(OCAMLC) $(CHKLIBS) $(BYTEFLAGS) -c $<
+
+checker/%.cmo: checker/%.ml
+	$(SHOW)'OCAMLC    $<'
+	$(HIDE)$(OCAMLC) $(CHKLIBS) $(BYTEFLAGS) -c $<
+
+checker/%.cmx: checker/%.ml
+	$(SHOW)'OCAMLOPT  $<'
+	$(HIDE)$(OCAMLOPT) $(CHKLIBS) $(OPTFLAGS) $(HACKMLI) -c $<
+
+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
+
+.PHONY: md5chk
+
+# For emacs:
+# Local Variables:
+# mode: makefile
+# End:
diff --git a/Makefile.common b/Makefile.common
index 1a903539..49fe1fd9 100644
--- a/Makefile.common
+++ b/Makefile.common
@@ -14,19 +14,32 @@
 
 COQMKTOP:=bin/coqmktop$(EXE) 
 
-COQC:=bin/coqc$(EXE)
-
 COQTOPBYTE:=bin/coqtop.byte$(EXE)
 COQTOPEXE:=bin/coqtop$(EXE)
 
-CHICKENBYTE:=bin/coqchk.byte$(EXE)
-CHICKEN:=bin/coqchk$(EXE)
+COQDEP:=bin/coqdep$(EXE)
+COQMAKEFILE:=bin/coq_makefile$(EXE)
+GALLINA:=bin/gallina$(EXE)
+COQTEX:=bin/coq-tex$(EXE)
+COQWC:=bin/coqwc$(EXE)
+COQDOC:=bin/coqdoc$(EXE)
+COQC:=bin/coqc$(EXE)
+COQWORKMGR:=bin/coqworkmgr$(EXE)
 
-ifeq ($(CAMLP4),camlp4)
-CAMLP4MOD:=camlp4lib
-else
-CAMLP4MOD:=gramlib
-endif
+TOOLS:=$(COQDEP) $(COQMAKEFILE) $(GALLINA) $(COQTEX) $(COQWC) $(COQDOC) $(COQC)\
+	$(COQWORKMGR)
+
+COQDEPBOOT:=bin/coqdep_boot$(EXE)
+OCAMLLIBDEP:=bin/ocamllibdep$(EXE)
+FAKEIDE:=bin/fake_ide$(EXE)
+
+PRIVATEBINARIES:=$(FAKEIDE) $(OCAMLLIBDEP) $(COQDEPBOOT)
+
+CSDPCERT:=plugins/micromega/csdpcert$(EXE)
+
+###########################################################################
+# Object and Source files
+###########################################################################
 
 ifeq ($(HASNATDYNLINK)-$(BEST),true-opt)
   DEPNATDYN:=
@@ -39,119 +52,22 @@ INSTALLLIB:=install -m 644
 INSTALLSH:=./install.sh
 MKDIR:=install -d
 
-COQIDEBYTE:=bin/coqide.byte$(EXE)
-COQIDE:=bin/coqide$(EXE)
-COQIDEAPP:=bin/CoqIDE_$(VERSION).app
-COQIDEINAPP:=$(COQIDEAPP)/Contents/MacOS/coqide
-
-ifeq ($(BEST),opt)
-OPT:=opt
-else
-OPT:=
-endif
-
-BESTOBJ:=$(if $(OPT),.cmx,.cmo)
-BESTLIB:=$(if $(OPT),.cmxa,.cma)
-BESTDYN:=$(if $(OPT),.cmxs,.cma)
-
-COQBINARIES:= $(COQMKTOP) \
-  $(COQTOPBYTE) $(COQTOPEXE) \
-  $(CHICKENBYTE) $(CHICKEN)
-
-CSDPCERT:=plugins/micromega/csdpcert$(EXE)
-
 CORESRCDIRS:=\
   config 	lib		kernel		kernel/byterun	library \
   proofs 	tactics 	pretyping	interp		stm \
-  toplevel	parsing	printing	grammar	        intf
+  toplevel	parsing 	printing	intf	engine	ltac
 
-PLUGINS:=\
+PLUGINDIRS:=\
   omega		romega 		micromega 	quote \
   setoid_ring 	extraction 	fourier \
   cc 		funind 		firstorder 	derive \
-  rtauto 	nsatz           syntax          decl_mode	btauto
+  rtauto 	nsatz           syntax          decl_mode	btauto \
+  ssrmatching
 
 SRCDIRS:=\
   $(CORESRCDIRS)  \
   tools 	tools/coqdoc	\
-  $(addprefix plugins/, $(PLUGINS))
-
-IDESRCDIRS:= $(CORESRCDIRS) ide ide/utils
-
-# Order is relevant here because kernel and checker contain files
-# with the same name
-CHKSRCDIRS:= checker lib config kernel parsing
-
-###########################################################################
-# Tools
-###########################################################################
-
-COQDEP:=bin/coqdep$(EXE)
-COQDEPBOOT:=bin/coqdep_boot$(EXE)
-COQMAKEFILE:=bin/coq_makefile$(EXE)
-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)
-
-PRIVATEBINARIES:=$(FAKEIDE) $(COQDEPBOOT)
-
-###########################################################################
-# Documentation
-###########################################################################
-
-LATEX:=latex
-BIBTEX:=BIBINPUTS=.: bibtex -min-crossrefs=10
-MAKEINDEX:=makeindex
-PDFLATEX:=pdflatex
-DVIPS:=dvips
-FIG2DEV:=fig2dev
-CONVERT:=convert
-HEVEA:=hevea
-HACHA:=hacha
-HEVEAOPTS:=-fix -exec xxdate.exe
-HEVEALIB:=/usr/local/lib/hevea:/usr/lib/hevea
-HTMLSTYLE:=simple
-export TEXINPUTS:=$(HEVEALIB):
-COQTEXOPTS:=-boot -n 72 -sl -small
-
-DOCCOMMON:=doc/common/version.tex doc/common/title.tex doc/common/macros.tex 
-
-REFMANCOQTEXFILES:=$(addprefix doc/refman/, \
-  RefMan-gal.v.tex RefMan-ext.v.tex \
-  RefMan-mod.v.tex RefMan-tac.v.tex \
-  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-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 Classes.v.tex Universes.v.tex \
-  Misc.v.tex)
-
-REFMANTEXFILES:=$(addprefix doc/refman/, \
-  headers.sty Reference-Manual.tex \
-  RefMan-pre.tex RefMan-int.tex RefMan-com.tex \
-  RefMan-uti.tex RefMan-ide.tex RefMan-add.tex RefMan-modr.tex \
-  AsyncProofs.tex ) \
-  $(REFMANCOQTEXFILES) \
-
-REFMANEPSFILES:=doc/refman/coqide.eps doc/refman/coqide-queries.eps
-
-REFMANFILES:=$(REFMANTEXFILES) $(DOCCOMMON) $(REFMANEPSFILES) doc/refman/biblio.bib
-
-REFMANPNGFILES:=$(REFMANEPSFILES:.eps=.png)
-
-
-
-###########################################################################
-# Object and Source files 
-###########################################################################
+  $(addprefix plugins/, $(PLUGINDIRS))
 
 COQRUN := coqrun
 LIBCOQRUN:=kernel/byterun/lib$(COQRUN).a
@@ -161,111 +77,69 @@ BYTERUN:=$(addprefix kernel/byterun/, \
   coq_fix_code.o coq_memory.o coq_values.o coq_interp.o )
 
 # LINK ORDER:
-# Beware that highparsing.cma should appear before hightactics.cma
+# Beware that highparsing.cma should appear before ltac.cma
 # respecting this order is useful for developers that want to load or link
 # the libraries directly
 
 CORECMA:=lib/clib.cma lib/lib.cma kernel/kernel.cma library/library.cma \
-        pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \
+        engine/engine.cma pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \
         parsing/parsing.cma printing/printing.cma tactics/tactics.cma \
-	stm/stm.cma toplevel/toplevel.cma parsing/highparsing.cma tactics/hightactics.cma
+	stm/stm.cma toplevel/toplevel.cma parsing/highparsing.cma ltac/ltac.cma
 
 TOPLOOPCMA:=stm/proofworkertop.cma stm/tacworkertop.cma stm/queryworkertop.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/setoid_ring/newring_plugin.cma
-NSATZCMA:=plugins/nsatz/nsatz_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
-BTAUTOCMA:=plugins/btauto/btauto_plugin.cma
-RTAUTOCMA:=plugins/rtauto/rtauto_plugin.cma
-NATSYNTAXCMA:=plugins/syntax/nat_syntax_plugin.cma
-OTHERSYNTAXCMA:=$(addprefix plugins/syntax/, \
-        z_syntax_plugin.cma \
-        numbers_syntax_plugin.cma \
-        r_syntax_plugin.cma \
-	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) \
-        $(FOURIERCMA) $(EXTRACTIONCMA) \
-        $(CCCMA)  $(FOCMA) $(RTAUTOCMA) $(BTAUTOCMA) \
-        $(FUNINDCMA) $(NSATZCMA) $(NATSYNTAXCMA) $(OTHERSYNTAXCMA) \
-	$(DERIVECMA)
-
-ifneq ($(HASNATDYNLINK),false)
- STATICPLUGINS:=
- INITPLUGINS:=$(EXTRACTIONCMA) $(FOCMA) $(CCCMA) \
-	$(FUNINDCMA) $(NATSYNTAXCMA)
- INITPLUGINSOPT:=$(INITPLUGINS:.cma=.cmxs)
- PLUGINS:=$(PLUGINSCMA)
- PLUGINSOPT:=$(PLUGINSCMA:.cma=.cmxs)
-else
-ifeq ($(BEST),byte)
- STATICPLUGINS:=
- INITPLUGINS:=$(EXTRACTIONCMA) $(FOCMA) $(CCCMA) \
-	$(FUNINDCMA) $(NATSYNTAXCMA)
- INITPLUGINSOPT:=$(INITPLUGINS:.cma=.cmxs)
- PLUGINS:=$(PLUGINSCMA)
- PLUGINSOPT:=$(PLUGINSCMA:.cma=.cmxs)
-else
- STATICPLUGINS:=$(PLUGINSCMA)
- INITPLUGINS:=
- INITPLUGINSOPT:=
- PLUGINS:=
- PLUGINSOPT:=
-endif
-endif
-
-LINKCMO:=$(CORECMA) $(STATICPLUGINS)
-LINKCMX:=$(CORECMA:.cma=.cmxa) $(STATICPLUGINS:.cma=.cmxa)
-
-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) $(IDECDEPS) $(IDECMA) ide/coqide_main.ml
-LINKIDEOPT:=$(IDEOPTCDEPS) $(patsubst %.cma,%.cmxa,$(IDEDEPS:.cmo=.cmx)) $(IDECMA:.cma=.cmxa) ide/coqide_main.ml
+GRAMMARCMA:=grammar/compat5.cmo grammar/grammar.cma
 
 # modules known by the toplevel of Coq
 
 OBJSMOD:=$(shell cat $(CORECMA:.cma=.mllib))
 
-IDEMOD:=$(shell cat ide/ide.mllib)
-
-# coqmktop, coqc
-
-COQENVCMO:=lib/clib.cma lib/errors.cmo
-
-COQMKTOPCMO:=$(COQENVCMO) tools/tolink.cmo tools/coqmktop.cmo
-
-COQCCMO:=$(COQENVCMO) toplevel/usage.cmo tools/coqc.cmo
-
-## Misc
-
-CSDPCERTCMO:=$(addprefix plugins/micromega/, \
-  mutils.cmo 	micromega.cmo \
-  sos_types.cmo sos_lib.cmo sos.cmo 	csdpcert.cmo )
-
-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:=lib/clib.cma $(addprefix tools/coqdoc/, \
-  cdglobals.cmo alpha.cmo index.cmo tokens.cmo output.cmo cpretty.cmo main.cmo )
+###########################################################################
+# plugins object files
+###########################################################################
+
+OMEGACMO:=plugins/omega/omega_plugin.cmo
+ROMEGACMO:=plugins/romega/romega_plugin.cmo
+MICROMEGACMO:=plugins/micromega/micromega_plugin.cmo
+QUOTECMO:=plugins/quote/quote_plugin.cmo
+RINGCMO:=plugins/setoid_ring/newring_plugin.cmo
+NSATZCMO:=plugins/nsatz/nsatz_plugin.cmo
+FOURIERCMO:=plugins/fourier/fourier_plugin.cmo
+EXTRACTIONCMO:=plugins/extraction/extraction_plugin.cmo
+FUNINDCMO:=plugins/funind/recdef_plugin.cmo
+FOCMO:=plugins/firstorder/ground_plugin.cmo
+CCCMO:=plugins/cc/cc_plugin.cmo
+BTAUTOCMO:=plugins/btauto/btauto_plugin.cmo
+RTAUTOCMO:=plugins/rtauto/rtauto_plugin.cmo
+NATSYNTAXCMO:=plugins/syntax/nat_syntax_plugin.cmo
+OTHERSYNTAXCMO:=$(addprefix plugins/syntax/, \
+        z_syntax_plugin.cmo \
+        numbers_syntax_plugin.cmo \
+        r_syntax_plugin.cmo \
+	ascii_syntax_plugin.cmo \
+        string_syntax_plugin.cmo )
+DECLMODECMO:=plugins/decl_mode/decl_mode_plugin.cmo
+DERIVECMO:=plugins/derive/derive_plugin.cmo
+SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo
+
+PLUGINSCMO:=$(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) $(DECLMODECMO) \
+        $(QUOTECMO) $(RINGCMO) \
+        $(FOURIERCMO) $(EXTRACTIONCMO) \
+        $(CCCMO)  $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \
+        $(FUNINDCMO) $(NSATZCMO) $(NATSYNTAXCMO) $(OTHERSYNTAXCMO) \
+	$(DERIVECMO) $(SSRMATCHINGCMO)
+
+ifeq ($(HASNATDYNLINK)-$(BEST),false-opt)
+ STATICPLUGINS:=$(PLUGINSCMO)
+ PLUGINS:=
+else
+ STATICPLUGINS:=
+ PLUGINS:=$(PLUGINSCMO)
+endif
+PLUGINSOPT:=$(PLUGINSCMO:.cmo=.cmxs)
 
-COQMAKEFILECMO:=lib/clib.cma ide/project_file.cmo tools/coq_makefile.cmo
+LINKCMO:=$(CORECMA) $(STATICPLUGINS)
+LINKCMX:=$(CORECMA:.cma=.cmxa) $(STATICPLUGINS:.cmo=.cmx)
 
 ###########################################################################
 # vo files
@@ -273,127 +147,41 @@ COQMAKEFILECMO:=lib/clib.cma ide/project_file.cmo tools/coq_makefile.cmo
 
 ## we now retrieve the names of .vo file to compile in */vo.itarget files
 
-cat_vo_itarget = $(addprefix $(1)/,$(shell cat $(1)/vo.itarget))
-
-## Theories
-
-INITVO:=$(call cat_vo_itarget, theories/Init)
-LOGICVO:=$(call cat_vo_itarget, theories/Logic)
-STRUCTURESVO:=$(call cat_vo_itarget, theories/Structures)
-ARITHVO:=$(call cat_vo_itarget, theories/Arith)
-SORTINGVO:=$(call cat_vo_itarget, theories/Sorting)
-BOOLVO:=$(call cat_vo_itarget, theories/Bool)
-PARITHVO:=$(call cat_vo_itarget, theories/PArith)
-NARITHVO:=$(call cat_vo_itarget, theories/NArith)
-ZARITHVO:=$(call cat_vo_itarget, theories/ZArith)
-QARITHVO:=$(call cat_vo_itarget, theories/QArith)
-LISTSVO:=$(call cat_vo_itarget, theories/Lists)
-VECTORSVO:=$(call cat_vo_itarget, theories/Vectors)
-STRINGSVO:=$(call cat_vo_itarget, theories/Strings)
-SETSVO:=$(call cat_vo_itarget, theories/Sets)
-FSETSVO:=$(call cat_vo_itarget, theories/FSets)
-MSETSVO:=$(call cat_vo_itarget, theories/MSets)
-RELATIONSVO:=$(call cat_vo_itarget, theories/Relations)
-WELLFOUNDEDVO:=$(call cat_vo_itarget, theories/Wellfounded)
-REALSVO:=$(call cat_vo_itarget, theories/Reals)
-NUMBERSVO:=$(call cat_vo_itarget, theories/Numbers)
-SETOIDSVO:=$(call cat_vo_itarget, theories/Setoids)
-UNICODEVO:=$(call cat_vo_itarget, theories/Unicode)
-CLASSESVO:=$(call cat_vo_itarget, theories/Classes)
-PROGRAMVO:=$(call cat_vo_itarget, theories/Program)
-COMPATVO:=$(call cat_vo_itarget, theories/Compat)
-
-THEORIESVO:=\
-  $(INITVO) $(LOGICVO) $(ARITHVO) $(BOOLVO) \
-  $(UNICODEVO) $(CLASSESVO) $(PROGRAMVO) \
-  $(RELATIONSVO) $(WELLFOUNDEDVO) $(SETOIDSVO) \
-  $(LISTSVO) $(STRINGSVO) \
-  $(PARITHVO) $(NARITHVO) $(ZARITHVO) \
-  $(SETSVO) $(FSETSVO) $(MSETSVO) \
-  $(REALSVO)  $(SORTINGVO) $(QARITHVO) \
-  $(NUMBERSVO) $(STRUCTURESVO) $(VECTORSVO) \
-  $(COMPATVO)
-
-THEORIESLIGHTVO:= $(INITVO) $(LOGICVO) $(UNICODEVO) $(ARITHVO)
-
-## Plugins
-
-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/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)
-CCVO:=
-DERIVEVO:=$(call cat_vo_itarget, plugins/derive)
-
-PLUGINSVO:= $(OMEGAVO) $(ROMEGAVO) $(MICROMEGAVO) \
-	    $(FOURIERVO) $(CCVO) $(FUNINDVO) \
-	    $(RTAUTOVO) $(BTAUTOVO) $(RINGVO) $(QUOTEVO) \
-            $(NSATZVO) $(EXTRACTIONVO) $(DERIVEVO)
+THEORIESVO:= $(foreach f, $(wildcard theories/*/vo.itarget), \
+                $(addprefix $(dir $(f)),$(shell cat $(f))))
+
+PLUGINSVO:=  $(foreach f, $(wildcard plugins/*/vo.itarget), \
+                $(addprefix $(dir $(f)),$(shell cat $(f))))
 
 ALLVO:= $(THEORIESVO) $(PLUGINSVO)
 VFILES:= $(ALLVO:.vo=.v)
+
+## More specific targets
+
+THEORIESLIGHTVO:= \
+ $(filter theories/Init/% theories/Logic/% theories/Unicode/% theories/Arith/%, $(THEORIESVO))
+
 ALLSTDLIB := test-suite/misc/universes/all_stdlib
 
 # convert a (stdlib) filename into a module name:
 # 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=))))
 
+ALLMODS:=$(call vo_to_mod,$(ALLVO))
+
+
 # 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) $(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)
-
-###########################################################################
-# Miscellaneous
-###########################################################################
-
-MANPAGES:=man/coq-tex.1 man/coqdep.1 man/gallina.1 \
-	man/coqc.1 man/coqtop.1 man/coqtop.byte.1 man/coqtop.opt.1 \
-	man/coqwc.1 man/coqdoc.1 man/coqide.1 \
-	man/coq_makefile.1 man/coqmktop.1 man/coqchk.1
-
-###########################################################################
-# Source documentation
-###########################################################################
-
-OCAMLDOCDIR=dev/ocamldoc
-
-DOCMLIS=$(wildcard ./lib/*.mli ./intf/*.mli ./kernel/*.mli ./library/*.mli \
-	./pretyping/*.mli ./interp/*.mli printing/*.mli \
-	./parsing/*.mli ./proofs/*.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.dev b/Makefile.dev
new file mode 100644
index 00000000..1f81edc2
--- /dev/null
+++ b/Makefile.dev
@@ -0,0 +1,223 @@
+#######################################################################
+#  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       #
+#######################################################################
+
+# Extra targets for developpers :
+# debug printers, revision, partial targets ...
+
+#########################
+# Debug printers in dev/
+#########################
+
+.PHONY: devel printers
+
+DEBUGPRINTERS:=dev/top_printers.cmo dev/vm_printers.cmo dev/printers.cma
+
+devel: printers
+printers: $(DEBUGPRINTERS)
+
+dev/printers.cma: dev/printers.mllib
+	$(SHOW)'Testing $@'
+	$(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(SYSCMA) $(P4CMA) $(filter-out %.mllib, $^) -o test-printer
+	@rm -f test-printer
+	$(SHOW)'OCAMLC -a $@'
+	$(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(SYSCMA) $(P4CMA) $(filter-out %.mllib, $^) -linkall -a -o $@
+
+dev/%.mllib.d: dev/%.mllib | $(OCAMLLIBDEP) $(GENFILES)
+	$(SHOW)'OCAMLLIBDEP  $<'
+	$(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) -I dev "$<" $(TOTARGET)
+
+############
+# revision
+############
+
+# display the revision number when compiling a checked out source tree
+
+revision:
+	$(SHOW)'CHECK revision'
+	$(HIDE)rm -f revision.new
+ifeq ($(CHECKEDOUT),svn)
+	$(HIDE)set -e; \
+        if test -x "`which svn`"; then \
+	  export LC_ALL=C;\
+	  svn info . | sed -ne '/URL/s/.*\/\([^\/]\{1,\}\)/\1/p' > revision.new; \
+	  svn info . | sed -ne '/Revision/s/Revision: \([0-9]\{1,\}\)/\1/p'>> revision.new; \
+	fi
+endif
+ifeq ($(CHECKEDOUT),gnuarch)
+	$(HIDE)set -e; \
+        if test -x "`which tla`"; then \
+	  LANG=C; export LANG; \
+	  tla tree-version  >  revision.new ; \
+	  tla tree-revision | sed -ne 's|.*--||p' >> revision.new ; \
+	fi
+endif
+ifeq ($(CHECKEDOUT),git)
+	$(HIDE)set -e; \
+	if test -x "`which git`"; then \
+	  LANG=C; export LANG; \
+	  GIT_BRANCH=$$(git branch -a | sed -ne '/^\* /s/^\* \(.*\)/\1/p'); \
+	  GIT_HOST=$$(hostname); \
+	  GIT_PATH=$$(pwd); \
+	  (echo "$${GIT_HOST}:$${GIT_PATH},$${GIT_BRANCH}") > revision.new; \
+	  (echo "$$(git log -1 --pretty='format:%H')") >> revision.new; \
+	fi
+endif
+	$(HIDE)set -e; \
+	if test -e revision.new; then \
+          if test -e revision; then \
+	    if test "`cat revision`" = "`cat revision.new`" ; then \
+	       rm -f revision.new; \
+            else \
+               mv -f revision.new revision; \
+            fi; \
+          else \
+            mv -f revision.new revision; \
+          fi \
+	fi
+
+.PHONY: revision
+
+###################
+# Partial builds
+###################
+
+# The following partial targets are normally not necessary
+# for a complete build of coq, see instead 'make world' for that.
+# But these partial targets could be quite handy for quick builds
+# of specific components of Coq.
+
+###############################
+### 1) general-purpose targets
+###############################
+
+coqlight: theories-light tools coqbinaries
+
+states: theories/Init/Prelude.vo
+
+miniopt: $(COQTOPEXE) pluginsopt
+minibyte: $(COQTOPBYTE) pluginsbyte
+
+pluginsopt: $(PLUGINSOPT)
+pluginsbyte: $(PLUGINS)
+
+.PHONY: coqlight states miniopt minibyte pluginsopt pluginsbyte
+
+##########################
+### 2) core ML components
+##########################
+
+lib: lib/clib.cma lib/lib.cma
+kernel: kernel/kernel.cma
+byterun: $(BYTERUN)
+library: library/library.cma
+engine: engine/engine.cma
+proofs: proofs/proofs.cma
+tactics: tactics/tactics.cma
+interp: interp/interp.cma
+parsing: parsing/parsing.cma
+pretyping: pretyping/pretyping.cma
+highparsing: parsing/highparsing.cma
+stm: stm/stm.cma
+toplevel: toplevel/toplevel.cma
+ltac: ltac/ltac.cma
+
+.PHONY: lib kernel byterun library proofs tactics interp parsing pretyping
+.PHONY: engine highparsing stm toplevel ltac
+
+######################
+### 3) theories files
+######################
+
+init: $(filter theories/Init/%, $(THEORIESVO))
+logic: $(filter theories/Logic/%, $(THEORIESVO))
+arith: $(filter theories/Arith/%, $(THEORIESVO))
+bool: $(filter theories/Bool/%, $(THEORIESVO))
+parith: $(filter theories/PArith/%, $(THEORIESVO))
+narith: $(filter theories/NArith/%, $(THEORIESVO))
+zarith: $(filter theories/ZArith/%, $(THEORIESVO))
+qarith: $(filter theories/QArith/%, $(THEORIESVO))
+lists: $(filter theories/Lists/%, $(THEORIESVO))
+strings: $(filter theories/Strings/%, $(THEORIESVO))
+sets: $(filter theories/Sets/%, $(THEORIESVO))
+fsets: $(filter theories/FSets/%, $(THEORIESVO))
+relations: $(filter theories/Relations/%, $(THEORIESVO))
+wellfounded: $(filter theories/Wellfounded/%, $(THEORIESVO))
+reals: $(filter theories/Reals/%, $(THEORIESVO))
+setoids: $(filter theories/Setoids/%, $(THEORIESVO))
+sorting: $(filter theories/Sorting/%, $(THEORIESVO))
+numbers: $(filter theories/Numbers/%, $(THEORIESVO))
+unicode: $(filter theories/Unicode/%, $(THEORIESVO))
+classes: $(filter theories/Classes/%, $(THEORIESVO))
+program: $(filter theories/Program/%, $(THEORIESVO))
+structures: $(filter theories/Structures/%, $(THEORIESVO))
+vectors: $(filter theories/Vectors/%, $(THEORIESVO))
+msets: $(filter theories/MSets/%, $(THEORIESVO))
+compat: $(filter theories/Compat/%, $(THEORIESVO))
+
+theories-light: $(THEORIESLIGHTVO)
+
+noreal: unicode logic arith bool zarith qarith lists sets fsets \
+	relations wellfounded setoids sorting
+
+.PHONY: init theories-light noreal
+.PHONY: logic arith bool narith zarith qarith lists strings sets
+.PHONY: fsets relations wellfounded reals setoids sorting numbers
+.PHONY: msets mmaps compat parith classes program unicode structures vectors
+
+################
+### 4) plugins
+################
+
+OMEGAVO:=$(filter plugins/omega/%, $(PLUGINSVO))
+ROMEGAVO:=$(filter plugins/romega/%, $(PLUGINSVO))
+MICROMEGAVO:=$(filter plugins/micromega/%, $(PLUGINSVO))
+QUOTEVO:=$(filter plugins/quote/%, $(PLUGINSVO))
+RINGVO:=$(filter plugins/setoid_ring/%, $(PLUGINSVO))
+NSATZVO:=$(filter plugins/nsatz/%, $(PLUGINSVO))
+FOURIERVO:=$(filter plugins/fourier/%, $(PLUGINSVO))
+FUNINDVO:=$(filter plugins/funind/%, $(PLUGINSVO))
+BTAUTOVO:=$(filter plugins/btauto/%, $(PLUGINSVO))
+RTAUTOVO:=$(filter plugins/rtauto/%, $(PLUGINSVO))
+EXTRACTIONVO:=$(filter plugins/extraction/%, $(PLUGINSVO))
+CCVO:=
+DERIVEVO:=$(filter plugins/derive/%, $(PLUGINSVO))
+
+omega: $(OMEGAVO) $(OMEGACMO) $(ROMEGAVO) $(ROMEGACMO)
+micromega: $(MICROMEGAVO) $(MICROMEGACMO) $(CSDPCERT)
+setoid_ring: $(RINGVO) $(RINGCMO)
+nsatz: $(NSATZVO) $(NSATZCMO)
+extraction: $(EXTRACTIONCMO)
+fourier: $(FOURIERVO) $(FOURIERCMO)
+funind: $(FUNINDCMO) $(FUNINDVO)
+cc: $(CCVO) $(CCCMO)
+rtauto: $(RTAUTOVO) $(RTAUTOCMO)
+btauto: $(BTAUTOVO) $(BTAUTOCMO)
+
+.PHONY: omega micromega setoid_ring nsatz extraction
+.PHONY: fourier funind cc rtauto btauto
+
+#################################
+### Misc other development rules
+#################################
+
+# NOTA : otags only accepts camlp4 as preprocessor, so the following rule
+# won't build tags of .ml4 when compiling with camlp5
+
+otags:
+	otags $(MLIFILES) $(filter-out configure.ml, $(MLSTATICFILES)) \
+	$(if $(filter camlp5,$(CAMLP4)), , \
+          -pa op -pa g -pa m -pa rq $(addprefix -pa , $(CAMLP4DEPS)) \
+          $(addprefix -impl , $(ML4FILES)))
+
+.PHONY: otags
+
+
+# For emacs:
+# Local Variables:
+# mode: makefile
+# End:
diff --git a/Makefile.doc b/Makefile.doc
index b7251ce5..cdd9852e 100644
--- a/Makefile.doc
+++ b/Makefile.doc
@@ -1,3 +1,11 @@
+#######################################################################
+#  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       #
+#######################################################################
+
 # Makefile for the Coq documentation
 
 # To compile documentation, you need the following tools:
@@ -5,6 +13,61 @@
 # Pdf: pdflatex
 # Html: hevea (http://hevea.inria.fr) >= 1.05
 
+# The main entry point :
+
+documentation: doc-$(WITHDOC)  ## see $(WITHDOC) in config/Makefile
+doc-all: doc
+doc-no:
+
+.PHONY: documentation doc-all doc-no
+
+######################################################################
+### Variables
+######################################################################
+
+LATEX:=latex
+BIBTEX:=BIBINPUTS=.: bibtex -min-crossrefs=10
+MAKEINDEX:=makeindex
+PDFLATEX:=pdflatex
+DVIPS:=dvips
+FIG2DEV:=fig2dev
+CONVERT:=convert
+HEVEA:=hevea
+HACHA:=hacha
+HEVEAOPTS:=-fix -exec xxdate.exe
+HEVEALIB:=/usr/local/lib/hevea:/usr/lib/hevea
+HTMLSTYLE:=simple
+export TEXINPUTS:=$(HEVEALIB):
+COQTEXOPTS:=-boot -n 72 -sl -small
+
+DOCCOMMON:=doc/common/version.tex doc/common/title.tex doc/common/macros.tex
+
+REFMANCOQTEXFILES:=$(addprefix doc/refman/, \
+  RefMan-gal.v.tex RefMan-ext.v.tex \
+  RefMan-mod.v.tex RefMan-tac.v.tex \
+  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-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 Classes.v.tex Universes.v.tex \
+  Misc.v.tex)
+
+REFMANTEXFILES:=$(addprefix doc/refman/, \
+  headers.sty Reference-Manual.tex \
+  RefMan-pre.tex RefMan-int.tex RefMan-com.tex \
+  RefMan-uti.tex RefMan-ide.tex RefMan-add.tex RefMan-modr.tex \
+  AsyncProofs.tex ) \
+  $(REFMANCOQTEXFILES) \
+
+REFMANEPSFILES:=doc/refman/coqide.eps doc/refman/coqide-queries.eps
+
+REFMANFILES:=$(REFMANTEXFILES) $(DOCCOMMON) $(REFMANEPSFILES) doc/refman/biblio.bib
+
+REFMANPNGFILES:=$(REFMANEPSFILES:.eps=.png)
+
+
 ######################################################################
 ### General rules
 ######################################################################
@@ -61,7 +124,7 @@ endif
 	(cd `dirname $<`; $(DVIPS) -q -o `basename $@` `basename $<`)
 
 %.png: %.fig
-	$(FIG2DEV) -m 2 -L png $< $@
+	$(FIG2DEV) -L png -m 2 $< $@
 
 %.pdf: %.fig
 	$(FIG2DEV) -L pdftex $< $@
@@ -140,9 +203,7 @@ doc/refman/styles.hva: doc/common/styles/html/$(HTMLSTYLE)/styles.hva
 INDEXES:= doc/refman/html/command-index.html doc/refman/html/tactic-index.html
 ALLINDEXES:= doc/refman/html/index.html $(INDEXES)
 
-$(ALLINDEXES): refman-html-dir
-
-refman-html-dir: doc/refman/Reference-Manual.html $(REFMANPNGFILES) \
+refman-html-dir $(ALLINDEXES): doc/refman/Reference-Manual.html $(REFMANPNGFILES) \
 	       doc/refman/cover.html doc/refman/styles.hva doc/refman/index.html
 	- rm -rf doc/refman/html
 	$(MKDIR) doc/refman/html
@@ -339,6 +400,80 @@ install-doc-index-urls:
 	$(MKDIR) $(FULLDATADIR)
 	$(INSTALLLIB) $(INDEXURLS) $(FULLDATADIR)
 
+
+###########################################################################
+# Documentation of the source code (using ocamldoc)
+###########################################################################
+
+OCAMLDOCDIR=dev/ocamldoc
+
+DOCMLIS=$(wildcard ./lib/*.mli ./intf/*.mli ./kernel/*.mli ./library/*.mli \
+	./engine/*.mli ./pretyping/*.mli ./interp/*.mli printing/*.mli \
+	./parsing/*.mli ./proofs/*.mli \
+	./tactics/*.mli ./stm/*.mli ./toplevel/*.mli ./ltac/*.mli)
+
+# Defining options to generate dependencies graphs
+DOT=dot
+ODOCDOTOPTS=-dot -dot-reduce
+
+.PHONY: source-doc mli-doc ml-doc
+
+source-doc: mli-doc $(OCAMLDOCDIR)/coq.pdf
+
+$(OCAMLDOCDIR)/coq.tex: $(DOCMLIS:.mli=.cmi)
+	$(SHOW)'OCAMLDOC -latex -o $@'
+	$(HIDE)$(OCAMLFIND) ocamldoc -latex -rectypes -I $(MYCAMLP4LIB) $(MLINCLUDES)\
+	$(DOCMLIS) -noheader -t "Coq mlis documentation" \
+	-intro $(OCAMLDOCDIR)/docintro -o $@.tmp
+	$(SHOW)'OCAMLDOC utf8 fix'
+	$(HIDE)$(OCAMLDOCDIR)/fix-ocamldoc-utf8 $@.tmp
+	$(HIDE)cat $(OCAMLDOCDIR)/header.tex $@.tmp > $@
+	rm $@.tmp
+
+mli-doc: $(DOCMLIS:.mli=.cmi)
+	$(SHOW)'OCAMLDOC -html'
+	$(HIDE)$(OCAMLFIND) ocamldoc -charset utf-8 -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)
+	$(OCAMLFIND) 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 $@
+
+%_types.dot: %.mli
+	$(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -dot-types -o $@ $<
+
+OCAMLDOC_MLLIBD = $(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ \
+  $(foreach lib,$(|:.mllib.d=_MLLIB_DEPENDENCIES),$(addsuffix .ml,$($(lib))))
+
+%.dot: | %.mllib.d
+	$(OCAMLDOC_MLLIBD)
+
+ml-doc:
+	$(OCAMLFIND) ocamldoc -charset utf-8 -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 ltac/ltac.mllib.d
+	$(OCAMLDOC_MLLIBD)
+
+%.dot: %.mli
+	$(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $<
+
+$(OCAMLDOCDIR)/%.pdf: $(OCAMLDOCDIR)/%.tex
+	$(SHOW)'PDFLATEX $*.tex'
+	$(HIDE)(cd $(OCAMLDOCDIR) ; pdflatex -interaction=batchmode $*.tex && pdflatex -interaction=batchmode $*.tex)
+	$(HIDE)(cd doc/tools/; show_latex_messages -no-overfull ../../$(OCAMLDOCDIR)/$*.log)
+
+
 # For emacs:
 # Local Variables:
 # mode: makefile
diff --git a/Makefile.ide b/Makefile.ide
new file mode 100644
index 00000000..48a269ab
--- /dev/null
+++ b/Makefile.ide
@@ -0,0 +1,255 @@
+#######################################################################
+#  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       #
+#######################################################################
+
+## Makefile rules for building the CoqIDE interface
+
+## NB: For the moment, the build system of CoqIDE is part of
+## the one of Coq. In particular, this Makefile.ide is included in
+## Makefile.build. Please ensure that the rules define here are
+## indeed specific to files of the form ide/*
+
+## Coqide-related variables set by ./configure in config/Makefile
+
+#COQIDEINCLUDES : something like -I +lablgtk2
+#HASCOQIDE : opt / byte / no
+#IDEFLAGS : some extra cma, for instance
+#IDEOPTCDEPS : on windows, ide/ide_win32_stubs.o ide/coq_icon.o
+#IDECDEPS
+#IDECDEPSFLAGS
+#IDEINT : X11 / QUARTZ / WIN32
+
+## CoqIDE Executable
+
+COQIDEBYTE:=bin/coqide.byte$(EXE)
+COQIDE:=bin/coqide$(EXE)
+COQIDEAPP:=bin/CoqIDE_$(VERSION).app
+COQIDEINAPP:=$(COQIDEAPP)/Contents/MacOS/coqide
+
+## CoqIDE source directory and files
+
+# Note : for just building bin/coqide, we could only consider
+# config, lib, ide and ide/utils. But the coqidetop plugin (the
+# one that will be loaded by coqtop -ideslave) refers to some
+# core modules of coq, for instance printing/*.
+
+IDESRCDIRS:= $(CORESRCDIRS) ide ide/utils
+
+COQIDEFLAGS=$(addprefix -I , $(IDESRCDIRS)) $(COQIDEINCLUDES)
+
+IDEDEPS:=lib/clib.cma lib/cErrors.cmo lib/spawn.cmo
+IDECMA:=ide/ide.cma
+IDETOPLOOPCMA=ide/coqidetop.cma
+
+LINKIDE:=$(IDEDEPS) $(IDECDEPS) $(IDECMA) ide/coqide_main.ml
+LINKIDEOPT:=$(IDEOPTCDEPS) $(patsubst %.cma,%.cmxa,$(IDEDEPS:.cmo=.cmx)) $(IDECMA:.cma=.cmxa) ide/coqide_main.ml
+
+IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png ide/MacOS/default_accel_map
+
+## 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)
+
+
+###########################################################################
+# CoqIde special targets
+###########################################################################
+
+.PHONY: coqide coqide-binaries coqide-no coqide-byte coqide-opt coqide-files
+.PHONY: ide-toploop
+
+# target to build CoqIde
+coqide: coqide-files coqide-binaries theories/Init/Prelude.vo
+
+coqide-binaries: coqide-$(HASCOQIDE) ide-toploop
+coqide-no:
+coqide-byte: $(COQIDEBYTE) $(COQIDE)
+coqide-opt:  $(COQIDEBYTE) $(COQIDE)
+coqide-files: $(IDEFILES)
+ifeq ($(BEST),opt)
+ide-toploop: $(IDETOPLOOPCMA) $(IDETOPLOOPCMA:.cma=.cmxs)
+else
+ide-toploop: $(IDETOPLOOPCMA)
+endif
+
+ifeq ($(HASCOQIDE),opt)
+$(COQIDE): $(LINKIDEOPT)
+	$(SHOW)'OCAMLOPT -o $@'
+	$(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)
+	$(SHOW)'OCAMLC -o $@'
+	$(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ unix.cma threads.cma lablgtk.cma \
+	        lablgtksourceview2.cma str.cma $(IDEFLAGS) $(IDECDEPSFLAGS) $^
+
+ide/coqide_main.ml: ide/coqide_main.ml4 config/Makefile # no camlp4deps here
+	$(SHOW)'CAMLP4O   $<'
+	$(HIDE)$(CAMLP4O) -I $(MYCAMLP4LIB) $(PR_O) $(CAMLP4USE) -D$(IDEINT) -impl $< -o $@
+
+
+ide/%.cmi: ide/%.mli
+	$(SHOW)'OCAMLC    $<'
+	$(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -c $<
+
+ide/%.cmo: ide/%.ml
+	$(SHOW)'OCAMLC    $<'
+	$(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -c $<
+
+ide/%.cmx: ide/%.ml
+	$(SHOW)'OCAMLOPT  $<'
+	$(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) $(HACKMLI) -c $<
+
+
+####################
+## Install targets
+####################
+
+.PHONY: install-coqide install-ide-bin install-ide-toploop install-ide-files install-ide-info install-ide-devfiles
+
+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-bin:
+	$(MKDIR) $(FULLBINDIR)
+	$(INSTALLBIN) $(COQIDE) $(FULLBINDIR)
+
+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))))
+ifeq ($(BEST),opt)
+	$(INSTALLSH) $(FULLCOQLIB) $(IDECMA:.cma=.cmxa) $(IDECMA:.cma=.a)
+endif
+
+install-ide-files: #Please update $(COQIDEAPP)/Contents/Resources/ at the same time
+	$(MKDIR) $(FULLDATADIR)
+	$(INSTALLLIB) ide/coq.png ide/*.lang ide/coq_style.xml $(FULLDATADIR)
+	$(MKDIR) $(FULLCONFIGDIR)
+	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/$(VERSION4MACOS)/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) $@
+
+###########################################################################
+# CoqIde for Windows special targets
+###########################################################################
+
+%.o: %.rc
+	$(SHOW)'WINDRES    $<'
+	$(HIDE)i686-w64-mingw32-windres -i $< -o $@
+
+
+# For emacs:
+# Local Variables:
+# mode: makefile
+# End:
diff --git a/Makefile.install b/Makefile.install
new file mode 100644
index 00000000..4800ea0b
--- /dev/null
+++ b/Makefile.install
@@ -0,0 +1,150 @@
+#######################################################################
+#  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       #
+#######################################################################
+
+# This makefile regroups installation rules
+# It is included by Makefile.build
+
+# NOTA: currently, the install rules below assume that everything needed
+# has already been correctly built. In particular, this is *not* enforced
+# by dependencies between rules, so do *not* try overly clever things like
+# 'make world install' in one unique command
+
+ifeq ($(LOCAL),true)
+install:
+	@echo "Nothing to install in a local build!"
+else
+install: install-coq install-coqide install-doc-$(WITHDOC) install-meta
+endif
+
+# NOTA: for install-coqide, see Makefile.ide
+
+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=
+
+  # Can be changed for a local installation (to make packages).
+  # You must NOT put a "/" at the end (Cygnus for win32 does not like "//").
+
+ifdef COQINSTALLPREFIX
+FULLBINDIR=$(BINDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
+FULLCOQLIB=$(COQLIBINSTALL:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
+FULLCONFIGDIR=$(CONFIGDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
+FULLDATADIR=$(DATADIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
+FULLMANDIR=$(MANDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
+FULLEMACSLIB=$(EMACSLIB:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
+FULLCOQDOCDIR=$(COQDOCDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
+FULLDOCDIR=$(DOCDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
+else
+FULLBINDIR=$(BINDIR)
+FULLCOQLIB=$(COQLIBINSTALL)
+FULLCONFIGDIR=$(CONFIGDIR)
+FULLDATADIR=$(DATADIR)
+FULLMANDIR=$(MANDIR)
+FULLEMACSLIB=$(EMACSLIB)
+FULLCOQDOCDIR=$(COQDOCDIR)
+FULLDOCDIR=$(DOCDIR)
+endif
+
+.PHONY: install-coq install-binaries install-byte install-opt
+.PHONY: install-tools install-library install-devfiles
+.PHONY: install-coq-info install-coq-manpages install-emacs install-latex
+.PHONY: install-meta
+
+install-coq: install-binaries install-library install-coq-info install-devfiles
+
+install-binaries: install-tools
+	$(MKDIR) $(FULLBINDIR)
+	$(INSTALLBIN) $(COQC) $(COQTOPBYTE) $(COQTOPEXE) $(CHICKEN) $(FULLBINDIR)
+	$(MKDIR) $(FULLCOQLIB)/toploop
+	$(INSTALLBIN) $(TOPLOOPCMA) $(FULLCOQLIB)/toploop/
+ifeq ($(BEST),opt)
+	$(INSTALLBIN) $(TOPLOOPCMA:.cma=.cmxs) $(FULLCOQLIB)/toploop/
+endif
+
+
+install-tools:
+	$(MKDIR) $(FULLBINDIR)
+	# recopie des fichiers de style pour coqide
+	$(MKDIR) $(FULLCOQLIB)/tools/coqdoc
+	touch $(FULLCOQLIB)/tools/coqdoc/coqdoc.sty $(FULLCOQLIB)/tools/coqdoc/coqdoc.css # to have the mode according to umask (bug #1715)
+	$(INSTALLLIB) tools/coqdoc/coqdoc.css tools/coqdoc/coqdoc.sty $(FULLCOQLIB)/tools/coqdoc
+	$(INSTALLBIN) $(TOOLS) $(FULLBINDIR)
+
+# The list of .cmi to install, including in particular
+# - the ones obtained from .mli without .ml
+# - the ones of modules in core cma's
+# - the ones corresponding to packed plugins
+
+INSTALLCMI = $(sort \
+	$(filter-out checker/% ide/% tools/%, $(MLIFILES:.mli=.cmi)) \
+	$(foreach lib,$(CORECMA), $(addsuffix .cmi,$($(lib:.cma=_MLLIB_DEPENDENCIES))))) \
+	$(PLUGINS:.cmo=.cmi)
+
+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)/user-contrib
+ifndef CUSTOM
+	$(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB)
+endif
+ifeq ($(BEST),opt)
+	$(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB)
+	$(INSTALLSH) $(FULLCOQLIB) $(PLUGINSOPT)
+endif
+# csdpcert is not meant to be directly called by the user; we install
+# it with libraries
+	-$(MKDIR) $(FULLCOQLIB)/plugins/micromega
+	$(INSTALLBIN) $(CSDPCERT) $(FULLCOQLIB)/plugins/micromega
+	rm -f $(FULLCOQLIB)/revision
+	-$(INSTALLLIB) revision $(FULLCOQLIB)
+
+install-coq-info: install-coq-manpages install-emacs install-latex
+
+MANPAGES:=man/coq-tex.1 man/coqdep.1 man/gallina.1 \
+	man/coqc.1 man/coqtop.1 man/coqtop.byte.1 man/coqtop.opt.1 \
+	man/coqwc.1 man/coqdoc.1 man/coqide.1 \
+	man/coq_makefile.1 man/coqmktop.1 man/coqchk.1
+
+install-coq-manpages:
+	$(MKDIR) $(FULLMANDIR)/man1
+	$(INSTALLLIB) $(MANPAGES) $(FULLMANDIR)/man1
+
+install-emacs:
+	$(MKDIR) $(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
+
+install-latex:
+	$(MKDIR) $(FULLCOQDOCDIR)
+	$(INSTALLLIB) tools/coqdoc/coqdoc.sty $(FULLCOQDOCDIR)
+#	-$(UPDATETEX)
+
+install-meta: META.coq
+	$(INSTALLLIB) META.coq $(FULLCOQLIB)/META
+
+# For emacs:
+# Local Variables:
+# mode: makefile
+# End:
diff --git a/README b/README
deleted file mode 100644
index 293ee4c8..00000000
--- a/README
+++ /dev/null
@@ -1,66 +0,0 @@
-
-               	         THE COQ V8 SYSTEM
-            	         =================
-
-INSTALLATION.
-=============
-
-   See the file INSTALL for installation procedure.
-
-
-DOCUMENTATION.
-==============
-
-   The documentation is part of the archive in directory doc. The
-   documentation of the last released version is available on the Coq
-   web site at http://coq.inria.fr/doc.
-
-
-CHANGES.
-========
-
-   There is a file named CHANGES that explains the differences and the
-   incompatibilities since last versions. If you upgrade Coq, please read
-   it carefully.
-
-
-AVAILABILITY.
-=============
-
-   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
-   subscription link can be found at http://coq.inria.fr/community.
-
-   The topics to be discussed in the club should include:
-
-     * technical problems;
-
-     * questions about proof developments;
-
-     * suggestions and questions about the implementation;
-
-     * announcements of proofs;
-
-     * theoretical questions about typed lambda-calculi which are
-       closely related to Coq.
-
-   For any questions/suggestions about the Coq Club, please write to
-   coq-club-request@inria.fr.
-
-
-BUGS REPORT.
-============
-
-   Send your bug reports by filling a form at
-
-        http://coq.inria.fr/bugs
-
-   To be effective, bug reports should mention the Caml version used
-   to compile and run Coq, the Coq version (coqtop -v), the configuration
-   used, and include a complete source example leading to the bug.
diff --git a/README.md b/README.md
new file mode 100644
index 00000000..a41ee7cc
--- /dev/null
+++ b/README.md
@@ -0,0 +1,44 @@
+# Coq
+Coq is a formal proof management system. It provides a formal language to write
+mathematical definitions, executable algorithms and theorems together with an
+environment for semi-interactive development of machine-checked proofs.
+
+## Installation
+See the file `INSTALL` for installation procedure.
+
+## Documentation
+The documentation is part of the archive in directory doc. The
+documentation of the last released version is available on the Coq
+web site at [coq.inria.fr/doc](http://coq.inria.fr/doc).
+
+## Changes
+There is a file named `CHANGES` that explains the differences and the
+incompatibilities since last versions. If you upgrade Coq, please read
+it carefully.
+
+## Availability
+Coq is available from [coq.inria.fr](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
+subscription link can be found at [coq.inria.fr/community](http://coq.inria.fr/community).
+
+The topics to be discussed in the club should include:
+
+* technical problems;
+* questions about proof developments;
+* suggestions and questions about the implementation;
+* announcements of proofs;
+* theoretical questions about typed lambda-calculi which are
+  closely related to Coq.
+
+For any questions/suggestions about the Coq Club, please write to
+`coq-club-request@inria.fr`.
+
+## Bugs report
+Send your bug reports by filling a form at [coq.inria.fr/bugs](http://coq.inria.fr/bugs).
+
+To be effective, bug reports should mention the OCaml version used
+to compile and run Coq, the Coq version (`coqtop -v`), the configuration
+used, and include a complete source example leading to the bug.
diff --git a/README.win b/README.win
deleted file mode 100644
index 8302a707..00000000
--- a/README.win
+++ /dev/null
@@ -1,44 +0,0 @@
-THE COQ V8 SYSTEM
-=================
-
-    This file contains remarks specific to the windows port of Coq.
-
-INSTALLATION.
-=============
-
-    The Coq package for Windows comes with an auto-installer. It will
-install Coq binaries and libraries under any directory you specify
-(C:\Coq is the default path). It also creates shortcuts
-in the Windows menus.  Binaries, like coqc.exe,
-are in the bin sub-directory of the installation
-(C:\Coq\bin by default).
-
-COMPILATION.
-============
-
-    If you want to install coq, you had better transfer the precompiled
-    distribution. If you really need to recompile under Windows, here
-    are some indications:
-
-    1- Install cygwin and the wget package
-       See: http://cygwin.com
-
-    2- Download and unzip in C:\ the SDK for windows
-       See: https://coq.inria.fr/distrib/current/files/
-
-    3- From the cygwin prompt type
-
-        . /cygdrive/c/CoqSDK-85-1/environ
-
-       The first time the script installs the C toolchain.
-
-    4- Then Coq can be compiled as follows:
- 
-        ./configure -local
-        make
-
-    5- To build the installer, type:
-
-        dev/make-installer-win32.sh
-
-    The Coq Team.
diff --git a/_tags b/_tags
deleted file mode 100644
index 5c978cab..00000000
--- a/_tags
+++ /dev/null
@@ -1,75 +0,0 @@
-
-## tags for binaries
-
-<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_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, 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_str
-
-## tags for ide
-
-<ide/**/*.{ml,mli}>: ide
-
-## tags for grammar.cm*
-
-<grammar/grammar.{cma,cmxa}> : use_unix
-
-## tags for camlp4 files 
-
-"parsing/g_constr.ml4": use_compat5
-"parsing/g_ltac.ml4": use_compat5
-"parsing/g_prim.ml4": use_compat5
-"parsing/g_proofs.ml4": use_compat5
-"parsing/g_tactic.ml4": use_compat5
-"parsing/g_vernac.ml4": use_compat5
-"parsing/g_xml.ml4": use_compat5
-"parsing/pcoq.ml4": use_compat5
-"parsing/g_obligations.ml4": use_grammar
-
-"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
-
-# Note: "checker" is deliberately not included
-# Note: same for "config" (we create a special coq_config.ml)
-
-"parsing": include
-"ide": include
-"ide/utils": include
-"interp": include
-"intf": include
-"grammar": include
-"kernel": include
-"kernel/byterun": include
-"lib": include
-"library": include
-"parsing": include
-"plugins": include
-"pretyping": include
-"printing": include
-"proofs": include
-"tactics": include
-"theories": include
-"tools": include
-"tools/coqdoc": include
-"toplevel": include
-
-<plugins/**>: include
diff --git a/build b/build
deleted file mode 100755
index debf29cf..00000000
--- a/build
+++ /dev/null
@@ -1,32 +0,0 @@
-#!/bin/sh
-
-FLAGS="-j 2"
-OCAMLBUILD=ocamlbuild
-MYCFG=myocamlbuild_config.ml
-
-export CAML_LD_LIBRARY_PATH=`pwd`/_build/kernel/byterun
-
-check_config() {
- if [ ! -f $MYCFG ]; then echo "please run ./configure first"; exit 1; fi
-}
-
-ocb() { $OCAMLBUILD $FLAGS $*; }
-
-rule() {
-  check_config
-  case $1 in
-    clean)  ocb -clean && rm -rf bin/*;;
-    all)    ocb coq.otarget;;
-    win32)  ocb coq-win32.otarget;;
-    *)      ocb $1;;
-  esac;
-}
-
-if [ $# -eq 0 ]; then
-  rule all
-else
-  while [ $# -gt 0 ]; do
-    rule $1;
-    shift
-  done
-fi
diff --git a/checker/check.ml b/checker/check.ml
index 3a5c9121..8b299bf2 100644
--- a/checker/check.ml
+++ b/checker/check.ml
@@ -7,10 +7,12 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 
+let chk_pp = Pp.pp_with Format.std_formatter
+
 let pr_dirpath dp = str (DirPath.to_string dp)
 let default_root_prefix = DirPath.empty
 let split_dirpath d =
@@ -111,15 +113,13 @@ 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 ppnl
+    (Flags.if_verbose Feedback.msg_notice
       (str "Admitting library: " ++ pr_dirpath dir);
       Safe_typing.unsafe_import file md m.library_extra_univs dig)
   else
-    (Flags.if_verbose ppnl
+    (Flags.if_verbose Feedback.msg_notice
       (str "Checking library: " ++ pr_dirpath dir);
       Safe_typing.import file md m.library_extra_univs dig);
-  Flags.if_verbose pp (fnl());
-  pp_flush ();
   register_loaded_library m
 
 (*************************************************************************)
@@ -173,7 +173,7 @@ let remove_load_path dir =
 
 let add_load_path (phys_path,coq_path) =
   if !Flags.debug then
-    ppnl (str "path: " ++ pr_dirpath coq_path ++ str " ->" ++ spc() ++
+    Feedback.msg_notice (str "path: " ++ pr_dirpath coq_path ++ str " ->" ++ spc() ++
            str phys_path);
   let phys_path = canonical_path_name phys_path in
   let physical, logical = !load_paths in
@@ -188,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
-		msg_warning
+		Feedback.msg_warning
 		  (str phys_path ++ strbrk " was previously bound to " ++
 		   pr_dirpath dir ++ strbrk "; it is remapped to " ++
 		   pr_dirpath coq_path);
@@ -299,12 +299,12 @@ let name_clash_message dir mdir f =
 let depgraph = ref LibraryMap.empty
 
 let intern_from_file (dir, f) =
-  Flags.if_verbose pp (str"[intern "++str f++str" ..."); pp_flush ();
+  Flags.if_verbose chk_pp (str"[intern "++str f++str" ...");
   let (sd,md,table,opaque_csts,digest) =
     try
       let ch = System.with_magic_number_check raw_intern_library f in
       let (sd:Cic.summary_disk), _, digest = System.marshal_in_segment f ch in
-      let (md:Cic.library_disk), _, _ = System.marshal_in_segment f ch in
+      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
@@ -323,7 +323,7 @@ let intern_from_file (dir, f) =
         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) ");
+       chk_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"))
@@ -334,12 +334,12 @@ let intern_from_file (dir, f) =
       Validate.validate !Flags.debug Values.v_libsum sd;
       Validate.validate !Flags.debug Values.v_lib md;
       Validate.validate !Flags.debug Values.v_opaques table;
-      Flags.if_verbose ppnl (str" done]"); pp_flush ();
+      Flags.if_verbose chk_pp (str" done]" ++ fnl ());
       let digest =
         if opaque_csts <> None then Cic.Dviovo (digest,udg)
         else (Cic.Dvo digest) in
       sd,md,table,opaque_csts,digest
-    with e -> Flags.if_verbose ppnl (str" failed!]"); raise e in
+    with e -> Flags.if_verbose chk_pp (str" failed!]" ++ fnl ()); raise e in
   depgraph := LibraryMap.add sd.md_name sd.md_deps !depgraph;
   opaque_tables := LibraryMap.add sd.md_name table !opaque_tables;
   Option.iter (fun (opaque_csts,_,_) ->
@@ -407,11 +407,11 @@ let recheck_library ~norec ~admit ~check =
   let nochk =
     List.fold_right LibrarySet.remove (List.map fst (nrl@ml)) nochk in
   (* *)
-  Flags.if_verbose ppnl (fnl()++hv 2 (str "Ordered list:" ++ fnl() ++
+  Flags.if_verbose Feedback.msg_notice (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 ppnl (str"Modules were successfully checked")
+  Flags.if_verbose Feedback.msg_notice (str"Modules were successfully checked")
 
 open Printf
 
diff --git a/checker/check.mllib b/checker/check.mllib
index 0d36e3a0..488507a1 100644
--- a/checker/check.mllib
+++ b/checker/check.mllib
@@ -8,6 +8,7 @@ Hashcons
 CSet
 CMap
 Int
+Dyn
 HMap
 Option
 Store
@@ -21,20 +22,25 @@ CList
 CString
 Serialize
 Stateid
-Feedback
-Pp
-Segmenttree
-Unicodetable
-Unicode
 CObj
 CArray
 CStack
 Util
+Pp
 Ppstyle
-Errors
-Ephemeron
+Xml_datatype
+Richpp
+Feedback
+Segmenttree
+Unicodetable
+Unicode
+CErrors
+CWarnings
+CEphemeron
 Future
 CUnix
+
+Minisys
 System
 Profile
 RemoteCounter
diff --git a/checker/check_stat.ml b/checker/check_stat.ml
index d031975d..741f5328 100644
--- a/checker/check_stat.ml
+++ b/checker/check_stat.ml
@@ -18,21 +18,16 @@ let print_memory_stat () =
   if !memory_stat then begin
     Format.printf "total heap size = %d kbytes\n" (CObj.heap_size_kb ());
     Format.print_newline();
-    flush_all()
+    Format.print_flush()
   end
 
 let output_context = ref false
 
-let pr_engagement (impr_set,type_in_type) =
+let pr_engagement impr_set =
   begin
     match impr_set with
     | ImpredicativeSet -> str "Theory: Set is impredicative"
     | PredicativeSet -> str "Theory: Set is predicative"
-  end ++
-  begin
-    match type_in_type with
-    | StratifiedType -> str "Theory: Stratified type hierarchy"
-    | TypeInType -> str "Theory: Type is of type Type"
   end
 
 let cst_filter f csts =
@@ -57,12 +52,12 @@ let print_context env =
          env_modules=mods; env_modtypes=mtys};
        env_stratification=
         {env_universes=univ; env_engagement=engt}} = env in
-    ppnl(hov 0
+    Feedback.msg_notice
+      (hov 0
       (fnl() ++ str"CONTEXT SUMMARY" ++ fnl() ++
       str"===============" ++ fnl() ++ fnl() ++
       str "* " ++ hov 0 (pr_engagement engt ++ fnl()) ++ fnl() ++
-      str "* " ++ hov 0 (pr_ax csts) ++
-      fnl())); pp_flush()
+      str "* " ++ hov 0 (pr_ax csts)));
   end
 
 let stats () =
diff --git a/checker/checker.ml b/checker/checker.ml
index 825fb4dc..8dbb7e01 100644
--- a/checker/checker.ml
+++ b/checker/checker.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open System
 open Flags
@@ -16,8 +16,10 @@ open Check
 
 let () = at_exit flush_all
 
+let chk_pp = Pp.pp_with Format.std_formatter
+
 let fatal_error info anomaly =
-  flush_all (); pperrnl info; flush_all ();
+  flush_all (); Feedback.msg_error info; flush_all ();
   exit (if anomaly then 129 else 1)
 
 let coq_root = Id.of_string "Coq"
@@ -67,12 +69,12 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath =
       Check.add_load_path (dir,coq_dirpath)
     end
   else
-    msg_warning (str "Cannot open " ++ str dir)
+    Feedback.msg_warning (str "Cannot open " ++ str dir)
 
 let convert_string d =
   try Id.of_string d
-  with Errors.UserError _ ->
-    if_verbose msg_warning
+  with CErrors.UserError _ ->
+    if_verbose Feedback.msg_warning
       (str "Directory " ++ str d ++ str " cannot be used as a Coq identifier (skipped)");
     raise Exit
 
@@ -90,7 +92,7 @@ let add_rec_path ~unix_path ~coq_root =
     List.iter Check.add_load_path dirs;
     Check.add_load_path (unix_path, coq_root)
   else
-    msg_warning (str "Cannot open " ++ str unix_path)
+    Feedback.msg_warning (str "Cannot open " ++ str unix_path)
 
 (* By the option -include -I or -R of the command line *)
 let includes = ref []
@@ -123,7 +125,7 @@ let init_load_path () =
     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 ~warn:(fun x -> msg_warning (str x)));
+    (xdg_dirs ~warn:(fun x -> Feedback.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 *)
@@ -140,9 +142,7 @@ let set_debug () = Flags.debug := true
 
 let impredicative_set = ref Cic.PredicativeSet
 let set_impredicative_set () = impredicative_set := Cic.ImpredicativeSet
-let type_in_type = ref Cic.StratifiedType
-let set_type_in_type () = type_in_type := Cic.TypeInType
-let engage () = Safe_typing.set_engagement (!impredicative_set,!type_in_type)
+let engage () = Safe_typing.set_engagement (!impredicative_set)
 
 
 let admit_list = ref ([] : section_path list)
@@ -179,10 +179,7 @@ let print_usage_channel co command =
   output_string co command;
   output_string co "coqchk 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\
-\n  -include dir           (idem)\
-\n  -R dir coqdir          recursively map physical dir to logical coqdir\
+"  -R dir coqdir          map physical dir to logical coqdir\
 \n\
 \n  -admit module          load module and dependencies without checking\
 \n  -norec module          check module but admit dependencies without checking\
@@ -195,7 +192,6 @@ let print_usage_channel co command =
 \n  -silent                disable trace of constants being checked\
 \n\
 \n  -impredicative-set     set sort Set impredicative\
-\n  -type-in-type          collapse type hierarchy\
 \n\
 \n  -h, --help             print this list of options\
 \n"
@@ -215,14 +211,9 @@ let usage () =
 open Type_errors
 
 let anomaly_string () = str "Anomaly: "
-let report () = (str "." ++ spc () ++ str "Please report.")
+let report () = (str "." ++ spc () ++ str "Please report" ++
+                 strbrk "at " ++ str Coq_config.wwwbugtracker ++ str ".")
 
-let print_loc loc =
-  if loc = Loc.ghost then
-    (str"<unknown>")
-  else
-    let loc = Loc.unloc loc in
-    (int (fst loc) ++ str"-" ++ int (snd loc))
 let guill s = str "\"" ++ str s ++ str "\""
 
 let where s =
@@ -294,7 +285,8 @@ let rec explain_exn = function
           Format.printf "@\nis not convertible with@\n";
           Print.print_pure_constr a;
           Format.printf "@\n====== universes ====@\n";
-          Pp.pp (Univ.pr_universes
+          chk_pp
+            (Univ.pr_universes
             (ctx.Environ.env_stratification.Environ.env_universes));
           str "\nCantApplyBadType at argument " ++ int n
       | CantApplyNonFunctional _ -> str"CantApplyNonFunctional"
@@ -315,15 +307,13 @@ let rec explain_exn = function
 		   str ", characters " ++ int e ++ str "-" ++
 		   int (e+6) ++ str ")")) ++
 	       report ())
-  | e -> Errors.print e (* for anomalies and other uncaught exceptions *)
+  | e -> CErrors.print e (* for anomalies and other uncaught exceptions *)
 
 let parse_args argv =
   let rec parse = function
     | [] -> ()
     | "-impredicative-set" :: rem ->
       set_impredicative_set (); parse rem
-    | "-type-in-type" :: rem ->
-      set_type_in_type (); parse rem
 
     | "-coqlib" :: s :: rem ->
       if not (exists_dir s) then 
@@ -337,15 +327,13 @@ let parse_args argv =
     | ("-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 ()
 
     | "-debug" :: rem -> set_debug (); parse rem
 
     | "-where" :: _ ->
-        Envars.set_coqlib ~fail:Errors.error;
+        Envars.set_coqlib ~fail:CErrors.error;
         print_endline (Envars.coqlib ());
         exit 0
 
@@ -383,7 +371,7 @@ let init_with_argv argv =
     try
       parse_args argv;
       if !Flags.debug then Printexc.record_backtrace true;
-      Envars.set_coqlib ~fail:Errors.error;
+      Envars.set_coqlib ~fail:CErrors.error;
       if_verbose print_header ();
       init_load_path ();
       engage ();
diff --git a/checker/cic.mli b/checker/cic.mli
index 041394d4..36455875 100644
--- a/checker/cic.mli
+++ b/checker/cic.mli
@@ -111,7 +111,8 @@ type cofixpoint = constr pcofixpoint
 
 (** {6 Type of assumptions and contexts}  *)
 
-type rel_declaration = Name.t * constr option * constr
+type rel_declaration = LocalAssum of Name.t * constr          (* name, type *)
+                     | LocalDef of Name.t * constr * constr   (* name, value, type *)
 type rel_context = rel_declaration list
 
 (** The declarations below in .vo should be outside sections,
@@ -166,9 +167,8 @@ type action
 (** Engagements *)
 
 type set_predicativity = ImpredicativeSet | PredicativeSet
-type type_hierarchy = TypeInType | StratifiedType
 
-type engagement = set_predicativity * type_hierarchy
+type engagement = set_predicativity
 
 (** {6 Representation of constants (Definition/Axiom) } *)
 
@@ -211,6 +211,16 @@ type constant_def =
 
 type constant_universes = Univ.universe_context
 
+(** The [typing_flags] are instructions to the type-checker which
+    modify its behaviour. The typing flags used in the type-checking
+    of a constant are tracked in their {!constant_body} so that they
+    can be displayed to the user. *)
+type typing_flags = {
+  check_guarded : bool; (** If [false] then fixed points and co-fixed
+                            points are assumed to be total. *)
+  check_universes : bool; (** If [false] universe constraints are not checked *)
+}
+
 type constant_body = {
     const_hyps : section_context; (** New: younger hyp at top *)
     const_body : constant_def;
@@ -219,7 +229,9 @@ type constant_body = {
     const_polymorphic : bool; (** Is it polymorphic or not *)
     const_universes : constant_universes;
     const_proj : projection_body option;
-    const_inline_code : bool }
+    const_inline_code : bool;
+    const_typing_flags : typing_flags;
+}
 
 (** {6 Representation of mutual inductive types } *)
 
@@ -315,9 +327,7 @@ type mutual_inductive_body = {
 
     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) *)
+    mind_typing_flags : typing_flags; (** typing flags at the time of the inductive creation *)
   }
 
 (** {6 Module declarations } *)
diff --git a/checker/closure.ml b/checker/closure.ml
index 400a535c..cef1d31a 100644
--- a/checker/closure.ml
+++ b/checker/closure.ml
@@ -29,7 +29,7 @@ let reset () =
   beta := 0; delta := 0; zeta := 0; evar := 0; iota := 0; prune := 0
 
 let stop() =
-  msg_debug (str "[Reds: beta=" ++ int !beta ++ str" delta=" ++ int !delta ++
+  Feedback.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"]")
 
@@ -217,10 +217,10 @@ let ref_value_cache info ref =
 let defined_rels flags env =
 (*  if red_local_const (snd flags) then*)
   fold_rel_context
-      (fun (id,b,t) (i,subs) ->
-	 match b with
-	   | None -> (i+1, subs)
-	   | Some body -> (i+1, (i,body) :: subs))
+      (fun decl (i,subs) ->
+	 match decl with
+	   | LocalAssum _ -> (i+1, subs)
+	   | LocalDef (_,body,_) -> (i+1, (i,body) :: subs))
       (rel_context env) ~init:(0,[])
 (*  else (0,[])*)
 
diff --git a/checker/declarations.ml b/checker/declarations.ml
index 32d1713a..1fe02c8b 100644
--- a/checker/declarations.ml
+++ b/checker/declarations.ml
@@ -73,32 +73,32 @@ let solve_delta_kn resolve kn =
       | Equiv kn1 -> kn1
       | Inline _ -> raise Not_found
   with Not_found ->
-    let mp,dir,l = repr_kn kn in
+    let mp,dir,l = KerName.repr kn in
     let new_mp = find_prefix resolve mp in
     if mp == new_mp then
       kn
     else
-      make_kn new_mp dir l
+      KerName.make new_mp dir l
 
 let gen_of_delta resolve x kn fix_can =
   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
-  gen_of_delta resolve con kn (constant_of_kn_equiv kn)
+  let kn = Constant.user con in
+  gen_of_delta resolve con kn (Constant.make 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 kn, kn' = Constant.canonical con, Constant.user con in
+  gen_of_delta resolve con kn (Constant.make 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 kn = MutInd.user mind in
+  gen_of_delta resolve mind kn (MutInd.make 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 kn, kn' = MutInd.canonical mind, MutInd.user mind in
+  gen_of_delta resolve mind kn (MutInd.make kn')
 
 let find_inline_of_delta kn resolve =
   match Deltamap.find_kn kn resolve with
@@ -106,7 +106,7 @@ let find_inline_of_delta kn resolve =
     | _ -> raise Not_found
 
 let constant_of_delta_with_inline resolve con =
-  let kn1,kn2 = canonical_con con,user_con con in
+  let kn1,kn2 = Constant.canonical con, Constant.user con in
   try find_inline_of_delta kn2 resolve
   with Not_found ->
     try find_inline_of_delta kn1 resolve
@@ -137,17 +137,17 @@ let subst_mp sub mp =
   | Some (mp',_) -> mp'
 
 let subst_kn_delta sub kn =
- let mp,dir,l = repr_kn kn in
+ let mp,dir,l = KerName.repr kn in
   match subst_mp0 sub mp with
      Some (mp',resolve) ->
-      solve_delta_kn resolve (make_kn mp' dir l)
+      solve_delta_kn resolve (KerName.make mp' dir l)
    | None -> kn
 
 let subst_kn sub kn =
- let mp,dir,l = repr_kn kn in
+ let mp,dir,l = KerName.repr kn in
   match subst_mp0 sub mp with
      Some (mp',_) ->
-      make_kn mp' dir l
+      KerName.make mp' dir l
    | None -> kn
 
 exception No_subst
@@ -165,14 +165,14 @@ let gen_subst_mp f sub mp1 mp2 =
     | 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 knu = KerName.make mpu dir l in
+  if mpu == mpc then MutInd.make1 knu
+  else MutInd.make knu (KerName.make 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
-  let mp2,_,_ = repr_kn kn2 in
+  let kn1,kn2 = MutInd.user mind, MutInd.canonical mind in
+  let mp1,dir,l = KerName.repr kn1 in
+  let mp2,_,_ = KerName.repr kn2 in
   let rebuild_mind mp1 mp2 = make_mind_equiv mp1 mp2 dir l in
   try
     let side,mind',resolve = gen_subst_mp rebuild_mind sub mp1 mp2 in
@@ -182,14 +182,14 @@ let subst_ind sub mind =
   with No_subst -> mind
 
 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 knu = KerName.make mpu dir l in
+  if mpu == mpc then Constant.make1 knu
+  else Constant.make knu (KerName.make 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 kn1,kn2 = Constant.user con, Constant.canonical con in
+  let mp1,dir,l = KerName.repr kn1 in
+  let mp2,_,_ = KerName.repr kn2 in
   let rebuild_con mp1 mp2 = make_con_equiv mp1 mp2 dir l in
   let dup con = con, Const (con, u) in
   let side,con',resolve = gen_subst_mp rebuild_con sub mp1 mp2 in
@@ -304,7 +304,9 @@ let subset_prefixed_by mp resolver =
     match hint with
       | Inline _ -> rslv
       | Equiv _ ->
-	if mp_in_mp mp (modpath kn) then Deltamap.add_kn kn hint rslv else rslv
+	if mp_in_mp mp (KerName.modpath kn)
+        then Deltamap.add_kn kn hint rslv
+        else rslv
   in
   Deltamap.fold mp_prefix kn_prefix resolver empty_delta_resolver
 
@@ -517,11 +519,8 @@ let map_decl_arity f g = function
   | RegularArity a -> RegularArity (f a)
   | TemplateArity a -> TemplateArity (g a)
 
-
-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_declaration sub =
+  Term.map_rel_decl (subst_mps sub)
 
 let subst_rel_context sub = List.smartmap (subst_rel_declaration sub)
 
diff --git a/checker/environ.ml b/checker/environ.ml
index f8f5c29b..7b59c6b9 100644
--- a/checker/environ.ml
+++ b/checker/environ.ml
@@ -1,4 +1,4 @@
-open Errors
+open CErrors
 open Util
 open Names
 open Cic
@@ -33,26 +33,21 @@ let empty_env = {
   env_rel_context = [];
   env_stratification =
   { env_universes = Univ.initial_universes;
-    env_engagement = (PredicativeSet,StratifiedType)};
+    env_engagement = PredicativeSet };
   env_imports = MPmap.empty }
 
 let engagement env = env.env_stratification.env_engagement
 let universes env = env.env_stratification.env_universes
 let rel_context env = env.env_rel_context
 
-let set_engagement (impr_set,type_in_type as c) env =
-  let expected_impr_set,expected_type_in_type =
+let set_engagement (impr_set as c) env =
+  let expected_impr_set =
     env.env_stratification.env_engagement in
   begin
     match impr_set,expected_impr_set with
     | PredicativeSet, ImpredicativeSet -> error "Incompatible engagement"
     | _ -> ()
   end;
-  begin
-    match type_in_type,expected_type_in_type with
-    | StratifiedType, TypeInType -> error "Incompatible engagement"
-    | _ -> ()
-  end;
   { env with env_stratification =
       { env.env_stratification with env_engagement = c } }
 
@@ -80,7 +75,7 @@ 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 -> LocalAssum (na, lift i t)) lna typarray in
   Array.fold_left (fun e assum -> push_rel assum e) env ctxt
 
 (* Universe constraints *)
@@ -112,7 +107,7 @@ 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")
-      (string_of_con kn);
+      (Constant.to_string kn);
   let new_constants =
     Cmap_env.add kn cs env.env_globals.env_constants in
   let new_globals =
@@ -172,12 +167,14 @@ let lookup_projection p env =
 let scrape_mind env kn=
   try
     KNmap.find kn env.env_globals.env_inductives_eq
-  with 
-      Not_found -> kn
+  with
+    Not_found -> kn
 
 let mind_equiv env (kn1,i1) (kn2,i2) =
   Int.equal i1 i2 &&
-  KerName.equal (scrape_mind env (user_mind kn1)) (scrape_mind env (user_mind kn2))
+  KerName.equal
+    (scrape_mind env (MutInd.user kn1))
+    (scrape_mind env (MutInd.user kn2))
 
 
 let lookup_mind kn env =
@@ -186,9 +183,9 @@ 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")
-      (string_of_mind kn);
+      (MutInd.to_string 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 kn1,kn2 =  MutInd.user kn, MutInd.canonical kn in
   let new_inds_eq = if KerName.equal kn1 kn2 then
     env.env_globals.env_inductives_eq
   else
@@ -205,7 +202,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")
-      (string_of_mp ln);
+      (ModPath.to_string ln);
   let new_modtypes = MPmap.add ln mtb env.env_globals.env_modtypes in
   let new_globals =
     { env.env_globals with
@@ -215,7 +212,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")
-      (string_of_mp mp);
+      (ModPath.to_string mp);
   let new_mods = MPmap.add mp mb env.env_globals.env_modules in
   let new_globals =
     { env.env_globals with
@@ -225,7 +222,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")
-      (string_of_mp mp);
+      (ModPath.to_string mp);
   let new_mods = MPmap.remove mp env.env_globals.env_modules in
   let new_globals =
     { env.env_globals with
diff --git a/checker/include b/checker/include
index f5bd2984..6bea3c91 100644
--- a/checker/include
+++ b/checker/include
@@ -31,7 +31,7 @@ open Typeops;;
 open Check;;
 
 open Pp;;
-open Errors;;
+open CErrors;;
 open Util;;
 open Names;;
 open Term;;
diff --git a/checker/indtypes.ml b/checker/indtypes.ml
index 2865f5bd..27f79e79 100644
--- a/checker/indtypes.ml
+++ b/checker/indtypes.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Cic
@@ -32,11 +32,11 @@ 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
+  let (mp,_,l) = KerName.repr kn in
   str(string_of_mp mp ^ "." ^ Label.to_string l)
 let prcon c =
-  let ck = canonical_con c in
-  let uk = user_con c in
+  let ck = Constant.canonical c in
+  let uk = Constant.user c in
   if KerName.equal ck uk then prkn uk else (prkn uk ++str"(="++prkn ck++str")")
 
 (* Same as noccur_between but may perform reductions.
@@ -44,7 +44,7 @@ let prcon c =
 let weaker_noccur_between env x nvars t =
   if noccur_between x nvars t then Some t
   else
-   let t' = whd_betadeltaiota env t in
+   let t' = whd_all env t in
    if noccur_between x nvars t' then Some t'
    else None
 
@@ -56,10 +56,10 @@ let is_constructor_head t =
 let conv_ctxt_prefix env (ctx1:rel_context) ctx2 =
   let rec chk env rctx1 rctx2 =
     match rctx1, rctx2 with
-        (_,None,ty1 as d1)::rctx1', (_,None,ty2)::rctx2' ->
+        (LocalAssum (_,ty1) as d1)::rctx1', LocalAssum (_,ty2)::rctx2' ->
           conv env ty1 ty2;
           chk (push_rel d1 env) rctx1' rctx2'
-      | (_,Some bd1,ty1 as d1)::rctx1', (_,Some bd2,ty2)::rctx2' ->
+      | (LocalDef (_,bd1,ty1) as d1)::rctx1', LocalDef (_,bd2,ty2)::rctx2' ->
           conv env ty1 ty2;
           conv env bd1 bd2;
           chk (push_rel d1 env) rctx1' rctx2'
@@ -90,14 +90,14 @@ exception InductiveError of inductive_error
 (* Typing the arities and constructor types *)
 
 let rec sorts_of_constr_args env t =
-  let t = whd_betadeltaiota_nolet env t in
+  let t = whd_allnolet env t in
   match t with
     | Prod (name,c1,c2) ->
         let varj = infer_type env c1 in
-	let env1 = push_rel (name,None,c1) env in
+	let env1 = push_rel (LocalAssum (name,c1)) env in
 	varj :: sorts_of_constr_args env1 c2
     | LetIn (name,def,ty,c) ->
-        let env1 = push_rel (name,Some def,ty) env in
+        let env1 = push_rel (LocalDef (name,def,ty)) env in
 	sorts_of_constr_args env1 c
     | _ when is_constructor_head t -> []
     | _ -> anomaly ~label:"infos_and_sort" (Pp.str "not a positive constructor")
@@ -167,7 +167,7 @@ let typecheck_arity env params inds =
 	   full_arity is used as argument or subject to cast, an
 	   upper universe will be generated *)
 	let id = ind.mind_typename in
-	let env_ar' = push_rel (Name id, None, arity) env_ar in
+	let env_ar' = push_rel (LocalAssum (Name id, arity)) env_ar in
         env_ar')
       env
       inds in
@@ -176,7 +176,7 @@ let typecheck_arity env params inds =
 (* Allowed eliminations *)
 
 let check_predicativity env s small level =
-  match s, fst (engagement env) with
+  match s, engagement env with
       Type u, _ ->
         (* let u' = fresh_local_univ () in *)
         (* let cst = *)
@@ -319,9 +319,9 @@ let check_correct_par (env,n,ntypes,_) hyps l largs =
   let nhyps = List.length hyps in
   let rec check k index = function
     | [] -> ()
-    | (_,Some _,_)::hyps -> check k (index+1) hyps
+    | LocalDef _ :: hyps -> check k (index+1) hyps
     | _::hyps ->
-        match whd_betadeltaiota env lpar.(k) with
+        match whd_all env lpar.(k) with
 	  | Rel w when w = index -> check (k-1) (index+1) hyps
 	  | _ -> raise (IllFormedInd (LocalNonPar (k+1,index,l)))
   in check (nparams-1) (n-nhyps) hyps;
@@ -340,9 +340,9 @@ let check_rec_par (env,n,_,_) hyps nrecp largs =
       | ([],_) -> ()
       | (_,[]) ->
           failwith "number of recursive parameters cannot be greater than the number of parameters."
-      | (lp,(_,Some _,_)::hyps) -> find (index-1) (lp,hyps)
+      | (lp,LocalDef _ :: hyps) -> find (index-1) (lp,hyps)
       | (p::lp,_::hyps) ->
-          (match whd_betadeltaiota env p with
+          (match whd_all env p with
 	    | Rel w when w = index -> find (index-1) (lp,hyps)
             | _ -> failwith "bad number of recursive parameters")
   in find (n-1) (lpar,List.rev hyps)
@@ -370,14 +370,15 @@ let abstract_mind_lc env ntyps npars lc =
    [lra] is the list of recursive tree of each variable
  *)
 let ienv_push_var (env, n, ntypes, lra) (x,a,ra) =
- (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra)
+ (push_rel (LocalAssum (x,a)) env, n+1, ntypes, (Norec,ra)::lra)
 
 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,u)) lpar) env in
+    let decl = LocalAssum (Anonymous,
+                           hnf_prod_applist env (type_of_inductive env (specif,u)) lpar) in
+    push_rel decl 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
@@ -387,7 +388,7 @@ let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lpar) =
 
 let rec ienv_decompose_prod (env,_,_,_ as ienv) n c =
   if n=0 then (ienv,c) else
-    let c' = whd_betadeltaiota env c in
+    let c' = whd_all env c in
     match c' with
 	Prod(na,a,b) ->
 	  let ienv' = ienv_push_var ienv (na,a,mk_norec) in
@@ -400,7 +401,7 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp (_,i as ind) indlc
   let lparams = rel_context_length hyps in
   (* check the inductive types occur positively in [c] *)
   let rec check_pos (env, n, ntypes, ra_env as ienv) c =
-    let x,largs = decompose_app (whd_betadeltaiota env c) in
+    let x,largs = decompose_app (whd_all env c) in
       match x with
 	| Prod (na,b,d) ->
 	    assert (List.is_empty largs);
@@ -469,7 +470,7 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp (_,i as ind) indlc
 
   and check_constructors ienv check_head c =
     let rec check_constr_rec (env,n,ntypes,ra_env as ienv) lrec c =
-      let x,largs = decompose_app (whd_betadeltaiota env c) in
+      let x,largs = decompose_app (whd_all env c) in
 	match x with
           | Prod (na,b,d) ->
 	      assert (List.is_empty largs);
@@ -527,7 +528,7 @@ let check_positivity env_ar mind params nrecp inds =
 (************************************************************************)
 
 let check_inductive env kn mib =
-  Flags.if_verbose ppnl (str "  checking ind: " ++ pr_mind kn); pp_flush ();
+  Flags.if_verbose Feedback.msg_notice (str "  checking ind: " ++ MutInd.print kn);
   (* check mind_constraints: should be consistent with env *)
   let env = add_constraints (Univ.UContext.constraints mib.mind_universes) env in
   (* check mind_record : TODO ? check #constructor = 1 ? *)
diff --git a/checker/inductive.ml b/checker/inductive.ml
index 79dba4fa..c4ffc141 100644
--- a/checker/inductive.ml
+++ b/checker/inductive.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Cic
@@ -31,20 +31,20 @@ let lookup_mind_specif env (kn,tyi) =
   (mib, mib.mind_packets.(tyi))
 
 let find_rectype env c =
-  let (t, l) = decompose_app (whd_betadeltaiota env c) in
+  let (t, l) = decompose_app (whd_all env c) in
   match t with
   | Ind ind -> (ind, l)
   | _ -> raise Not_found
 
 let find_inductive env c =
-  let (t, l) = decompose_app (whd_betadeltaiota env c) in
+  let (t, l) = decompose_app (whd_all env c) in
   match t with
     | 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
+  let (t, l) = decompose_app (whd_all env c) in
   match t with
     | Ind (ind,_)
         when (fst (lookup_mind_specif env ind)).mind_finite == CoFinite -> (ind, l)
@@ -59,16 +59,6 @@ let inductive_instance mib =
     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 *)
@@ -88,10 +78,10 @@ let instantiate_params full t u args sign =
     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))    -> 
+      (fun decl (largs,subs,ty) ->
+        match (decl, largs, ty) with
+          | (LocalAssum _, a::args, Prod(_,_,t)) -> (args, a::subs, t)
+          | (LocalDef (_,b,_),_,LetIn(_,_,_,t))    ->
 	    (largs, (substl subs (subst_instance_constr u b))::subs, t)
 	  | (_,[],_)                -> if full then fail() else ([], subs, ty)
 	  | _                       -> fail ())
@@ -161,7 +151,7 @@ let remember_subst u subst =
 (* Propagate the new levels in the signature *)
 let rec make_subst env =
   let rec make subst = function
-    | (_,Some _,_)::sign, exp, args ->
+    | LocalDef _ :: sign, exp, args ->
         make subst (sign, exp, args)
     | d::sign, None::exp, args ->
         let args = match args with _::args -> args | [] -> [] in
@@ -174,7 +164,7 @@ let rec make_subst env =
         (* a useless extra constraint *)
         let s = sort_as_univ (snd (dest_arity env a)) in
         make (cons_subst u s subst) (sign, exp, args)
-    | (na,None,t)::sign, Some u::exp, [] ->
+    | LocalAssum (na,t) :: sign, Some u::exp, [] ->
         (* No more argument here: we add the remaining universes to the *)
         (* substitution (when [u] is distinct from all other universes in the *)
         (* template, it is identity substitution  otherwise (ie. when u is *)
@@ -190,8 +180,6 @@ let rec make_subst env =
   in
   make Univ.LMap.empty
 
-exception SingletonInductiveBecomesProp of Id.t
-
 let instantiate_universes env ctx ar argsorts =
   let args = Array.to_list argsorts in
   let subst = make_subst env (ctx,ar.template_param_levels,args) in
@@ -208,11 +196,7 @@ let instantiate_universes env ctx ar argsorts =
 
 (* 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 =
+let type_of_inductive_gen env ((mib,mip),u) paramtyps =
   match mip.mind_arity with
   | RegularArity a ->
     if not mib.mind_polymorphic then a.mind_user_arity
@@ -220,25 +204,7 @@ let type_of_inductive_gen ?(polyprop=true) env ((mib,mip),u) paramtyps =
   | 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)
+    mkArity (List.rev ctx,s)
 
 let type_of_inductive_knowing_parameters env mip args = 
   type_of_inductive_gen env mip args
@@ -275,16 +241,6 @@ let type_of_constructor_gen (cstr,u) (mib,mip as 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 u mib) specif
@@ -319,8 +275,8 @@ let elim_sorts (_,mip) = mip.mind_kelim
 
 let extended_rel_list n hyps =
   let rec reln l p = function
-    | (_,None,_) :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps
-    | (_,Some _,_) :: hyps -> reln l (p+1) hyps
+    | LocalAssum _ :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps
+    | LocalDef _ :: hyps -> reln l (p+1) hyps
     | [] -> l
   in
   reln [] 1 hyps
@@ -343,15 +299,15 @@ let check_allowed_sort ksort specif =
 let is_correct_arity env c (p,pj) ind specif params =
   let arsign,_ = get_instantiated_arity ind specif params in
   let rec srec env pt ar =
-    let pt' = whd_betadeltaiota env pt in
+    let pt' = whd_all env pt in
     match pt', ar with
-      | Prod (na1,a1,t), (_,None,a1')::ar' ->
+      | Prod (na1,a1,t), LocalAssum (_,a1')::ar' ->
           (try conv env a1 a1'
           with NotConvertible -> raise (LocalArity None));
-          srec (push_rel (na1,None,a1) env) t ar'
+          srec (push_rel (LocalAssum (na1,a1)) env) t ar'
       | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *)
-	 let env' = push_rel (na1,None,a1) env in
-     let ksort = match (whd_betadeltaiota env' a2) with
+	 let env' = push_rel (LocalAssum (na1,a1)) env in
+     let ksort = match (whd_all env' a2) with
         | Sort s -> family_of_sort s
 	    | _ -> raise (LocalArity None) in
 	  let dep_ind = build_dependent_inductive ind specif params in
@@ -362,8 +318,8 @@ let is_correct_arity env c (p,pj) ind specif params =
       | Sort s', [] ->
 	  check_allowed_sort (family_of_sort s') specif;
 	  false
-      | _, (_,Some _,_ as d)::ar' ->
-	 srec (push_rel d env) (lift 1 pt') ar'
+      | _, (LocalDef _ as d)::ar' ->
+         srec (push_rel d env) (lift 1 pt') ar'
       | _ ->
 	  raise (LocalArity None)
   in
@@ -527,10 +483,10 @@ type guard_env =
 let make_renv env recarg tree =
   { env = env;
     rel_min = recarg+2; (* recarg = 0 ==> Rel 1 -> recarg; Rel 2 -> fix *)
-    genv = [Lazy.lazy_from_val(Subterm(Large,tree))] }
+    genv = [Lazy.from_val(Subterm(Large,tree))] }
 
 let push_var renv (x,ty,spec) =
-  { env = push_rel (x,None,ty) renv.env;
+  { env = push_rel (LocalAssum (x,ty)) renv.env;
     rel_min = renv.rel_min+1;
     genv = spec:: renv.genv }
 
@@ -538,7 +494,7 @@ let assign_var_spec renv (i,spec) =
   { renv with genv = List.assign renv.genv (i-1) spec }
 
 let push_var_renv renv (x,ty) =
-  push_var renv (x,ty,Lazy.lazy_from_val Not_subterm)
+  push_var renv (x,ty,Lazy.from_val Not_subterm)
 
 (* Fetch recursive information about a variable p *)
 let subterm_var p renv =
@@ -549,13 +505,13 @@ let push_ctxt_renv renv ctxt =
   let n = rel_context_length ctxt in
   { 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 }
+    genv = iterate (fun ge -> Lazy.from_val Not_subterm::ge) n renv.genv }
 
 let push_fix_renv renv (_,v,_ as recdef) =
   let n = Array.length v in
   { 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 }
+    genv = iterate (fun ge -> Lazy.from_val Not_subterm::ge) n renv.genv }
 
 
 (* Definition and manipulation of the stack *)
@@ -622,20 +578,21 @@ let check_inductive_codomain env p =
   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
+  let i,l' = decompose_app (whd_all 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)
+(push_rel (LocalAssum (x,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
+     let decl = LocalAssum (Anonymous,
+		            hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) in
+     push_rel decl 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
@@ -645,7 +602,7 @@ let ienv_push_inductive (env, ra_env) ((mind,u),lpar) =
 
 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
+   let c' = whd_all env c in
    match c' with
    Prod(na,a,b) ->
      let ienv' = ienv_push_var ienv (na,a,mk_norec) in
@@ -675,7 +632,7 @@ 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
+    let x,largs = decompose_app (whd_all env c) in
     match x with
     | Prod (na,b,d) ->
        assert (List.is_empty largs);
@@ -734,7 +691,7 @@ let get_recargs_approx env tree ind args =
 
   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
+      let x,largs = decompose_app (whd_all env c) in
 	match x with
 
           | Prod (na,b,d) ->
@@ -763,7 +720,7 @@ let restrict_spec env spec p =
   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
+  let i,args = decompose_app (whd_all env s) in
   match i with
   | Ind i ->
      begin match spec with
@@ -785,7 +742,7 @@ let restrict_spec env spec p =
 
 let rec subterm_specif renv stack t =
   (* maybe reduction is not always necessary! *)
-  let f,l = decompose_app (whd_betadeltaiota renv.env t) in
+  let f,l = decompose_app (whd_all renv.env t) in
     match f with
       | Rel k -> subterm_var k renv
 
@@ -861,7 +818,7 @@ and stack_element_specif = function
   |SArg x -> x
 
 and extract_stack renv a = function
-  | [] -> Lazy.lazy_from_val Not_subterm , []
+  | [] -> Lazy.from_val Not_subterm , []
   | h::t -> stack_element_specif h, t
 
 
@@ -899,11 +856,11 @@ let filter_stack_domain env ci p stack =
   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
+    let t = whd_all 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 d = LocalAssum (n,a) in
+      let ty, args = decompose_app (whd_all env a) in
       let elt = match ty with
       | Ind ind -> 
         let spec' = stack_element_specif elt in
@@ -956,10 +913,10 @@ let check_one_fix renv recpos trees def =
               end
             else
               begin
-                match pi2 (lookup_rel p renv.env) with
-                | None ->
+                match lookup_rel p renv.env with
+                | LocalAssum _ ->
                     List.iter (check_rec_call renv []) l
-                | Some c ->
+                | LocalDef (_,c,_) ->
                     try List.iter (check_rec_call renv []) l
                     with FixGuardError _ ->
                       check_rec_call renv stack (applist(lift p c,l))
@@ -1032,6 +989,10 @@ let check_one_fix renv recpos trees def =
         | (Ind _ | Construct _) ->
             List.iter (check_rec_call renv []) l
 
+	| Proj (p, c) ->
+            List.iter (check_rec_call renv []) l;
+            check_rec_call renv [] c
+
         | Var _ -> anomaly (Pp.str "Section variable in Coqchk !")
 
 	| Sort _ -> assert (l = [])
@@ -1041,8 +1002,6 @@ let check_one_fix renv recpos trees 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
@@ -1075,10 +1034,10 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
     (* check fi does not appear in the k+1 first abstractions,
        gives the type of the k+1-eme abstraction (must be an inductive)  *)
     let rec check_occur env n def =
-      match (whd_betadeltaiota env def) with
+      match (whd_all env def) with
         | Lambda (x,a,b) ->
 	    if noccur_with_meta n nbfix a then
-	      let env' = push_rel (x, None, a) env in
+	      let env' = push_rel (LocalAssum (x,a)) env in
               if n = k+1 then
                 (* get the inductive type of the fixpoint *)
                 let (mind, _) =
@@ -1124,10 +1083,10 @@ let anomaly_ill_typed () =
   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
+  let b = whd_all env c in
   match b with
     | Prod (x,a,b) ->
-	codomain_is_coind (push_rel (x, None, a) env) b
+	codomain_is_coind (push_rel (LocalAssum (x,a)) env) b
     | _ ->
 	(try find_coinductive env b
         with Not_found ->
@@ -1136,7 +1095,7 @@ let rec codomain_is_coind env c =
 let check_one_cofix env nbfix def deftype =
   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
+      let c,args = decompose_app (whd_all env t) in
       match c with
 	| Rel p when  n <= p && p < n+nbfix ->
 	    (* recursive call: must be guarded and no nested recursive
@@ -1168,7 +1127,7 @@ let check_one_cofix env nbfix def deftype =
 	| Lambda (x,a,b) ->
 	     assert (args = []);
             if noccur_with_meta n nbfix a then
-              let env' = push_rel (x, None, a) env in
+              let env' = push_rel (LocalAssum (x,a)) env in
               check_rec_call env' alreadygrd (n+1) tree vlra b
             else
 	      raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a))
diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml
index 3ea5ed0d..7f93e156 100644
--- a/checker/mod_checking.ml
+++ b/checker/mod_checking.ml
@@ -18,7 +18,7 @@ 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 ul = Univ.Level.make empty_dirpath 1 in
+      let ul = Univ.Level.make DirPath.empty 1 in
       let u' = Univ.Universe.make ul in
       let cst = Univ.enforce_leq u u' Univ.empty_constraint in
       let ctx = Univ.ContextSet.make (Univ.LSet.singleton ul) cst in
@@ -26,7 +26,7 @@ let refresh_arity ar =
     | _ -> ar, Univ.ContextSet.empty
 
 let check_constant_declaration env kn cb =
-  Flags.if_verbose ppnl (str "  checking cst: " ++ prcon kn); pp_flush ();
+  Flags.if_verbose Feedback.msg_notice (str "  checking cst: " ++ prcon kn);
   let env' =
     if cb.const_polymorphic then
       let inst = Univ.make_abstract_instance cb.const_universes in
@@ -70,7 +70,7 @@ let check_constant_declaration env kn cb =
 let lookup_module mp env =
   try Environ.lookup_module mp env
   with Not_found ->
-    failwith ("Unknown module: "^string_of_mp mp)
+    failwith ("Unknown module: "^ModPath.to_string mp)
 
 let mk_mtb mp sign delta =
   { mod_mp = mp;
diff --git a/checker/modops.ml b/checker/modops.ml
index 9f437526..b720fb62 100644
--- a/checker/modops.ml
+++ b/checker/modops.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 (*i*)
-open Errors
+open CErrors
 open Util
 open Pp
 open Names
@@ -28,7 +28,7 @@ let error_not_match 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
+  let l1 = ModPath.to_string l1 in
   error ("The field "^
          Label.to_string l^" is missing in "^l1^".")
 
diff --git a/checker/print.ml b/checker/print.ml
index 9cd8fda5..7ef752b0 100644
--- a/checker/print.ml
+++ b/checker/print.ml
@@ -10,7 +10,9 @@ open Format
 open Cic
 open Names
 
-let print_instance i = Pp.pp (Univ.Instance.pr i)
+let chk_pp = Pp.pp_with Format.std_formatter
+
+let print_instance i = chk_pp (Univ.Instance.pr i)
 
 let print_pure_constr csr =
   let rec term_display c = match  c with
@@ -108,7 +110,7 @@ let print_pure_constr csr =
   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 ")"
+    | Type u -> print_string "Type("; chk_pp (Univ.pr_uni u); print_string ")"
 
   and name_display = function
     | Name id -> print_string (Id.to_string id)
@@ -122,7 +124,7 @@ let print_pure_constr csr =
 	| ("Coq"::_::l) -> l
 	| l             -> l
     in  List.iter (fun x -> print_string x; print_string ".") ls;*)
-      print_string (debug_string_of_mind sp)
+      print_string (MutInd.debug_to_string sp)
   and sp_con_display sp =
 (*    let dir,l = decode_kn sp in
     let ls =
@@ -131,7 +133,7 @@ let print_pure_constr csr =
 	| ("Coq"::_::l) -> l
 	| l             -> l
     in  List.iter (fun x -> print_string x; print_string ".") ls;*)
-      print_string (debug_string_of_con sp)
+      print_string (Constant.debug_to_string sp)
 
   in
     try
diff --git a/checker/reduction.ml b/checker/reduction.ml
index 3a666a60..ec16aa26 100644
--- a/checker/reduction.ml
+++ b/checker/reduction.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Cic
 open Term
@@ -92,13 +92,13 @@ let whd_betaiotazeta x =
        Prod _|Lambda _|Fix _|CoFix _) -> x
     | _ -> whd_val (create_clos_infos betaiotazeta empty_env) (inject x)
 
-let whd_betadeltaiota env t =
+let whd_all env t =
   match t with
     | (Sort _|Meta _|Evar _|Ind _|Construct _|
        Prod _|Lambda _|Fix _|CoFix _) -> t
     | _ -> whd_val (create_clos_infos betadeltaiota env) (inject t)
 
-let whd_betadeltaiota_nolet env t =
+let whd_allnolet env t =
   match t with
     | (Sort _|Meta _|Evar _|Ind _|Construct _|
        Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t
@@ -167,8 +167,9 @@ let sort_cmp env univ pb s0 s1 =
             CUMUL -> ()
           | _ -> raise NotConvertible)
     | (Type u1, Type u2) ->
-        if snd (engagement env) == StratifiedType
-          && not
+        (** FIXME: handle type-in-type option here *)
+        if (* snd (engagement env) == StratifiedType && *)
+          not
 	  (match pb with
             | CONV -> Univ.check_eq univ u1 u2
 	    | CUMUL -> Univ.check_leq univ u1 u2)
@@ -476,7 +477,7 @@ let vm_conv cv_pb = fconv cv_pb true
  * error message. *)
 
 let hnf_prod_app env t n =
-  match whd_betadeltaiota env t with
+  match whd_all env t with
     | Prod (_,_,b) -> subst1 n b
     | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product")
 
@@ -487,10 +488,10 @@ let hnf_prod_applist env t nl =
 
 let dest_prod env =
   let rec decrec env m c =
-    let t = whd_betadeltaiota env c in
+    let t = whd_all env c in
     match t with
       | Prod (n,a,c0) ->
-          let d = (n,None,a) in
+          let d = LocalAssum (n,a) in
 	  decrec (push_rel d env) (d::m) c0
       | _ -> m,t
   in
@@ -499,17 +500,17 @@ let dest_prod env =
 (* 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
+    let rty = whd_allnolet env ty in
     match rty with
     | Prod (x,t,c)  ->
-        let d = (x,None,t) in
+        let d = LocalAssum (x,t) in
 	prodec_rec (push_rel d env) (d::l) c
     | LetIn (x,b,t,c) ->
-        let d = (x,Some b,t) in
+        let d = LocalDef (x,b,t) in
 	prodec_rec (push_rel d env) (d::l) c
     | Cast (c,_,_)    -> prodec_rec env l c
     | _               ->
-      let rty' = whd_betadeltaiota env rty in
+      let rty' = whd_all env rty in
 	if Term.eq_constr rty' rty then l, rty
 	else prodec_rec env l rty'
   in
@@ -517,13 +518,13 @@ let dest_prod_assum env =
 
 let dest_lam_assum env =
   let rec lamec_rec env l ty =
-    let rty = whd_betadeltaiota_nolet env ty in
+    let rty = whd_allnolet env ty in
     match rty with
     | Lambda (x,t,c)  ->
-        let d = (x,None,t) in
+        let d = LocalAssum (x,t) in
 	lamec_rec (push_rel d env) (d::l) c
     | LetIn (x,b,t,c) ->
-        let d = (x,Some b,t) in
+        let d = LocalDef (x,b,t) in
 	lamec_rec (push_rel d env) (d::l) c
     | Cast (c,_,_)    -> lamec_rec env l c
     | _               -> l,rty
diff --git a/checker/reduction.mli b/checker/reduction.mli
index 2f551f4a..15a2df1f 100644
--- a/checker/reduction.mli
+++ b/checker/reduction.mli
@@ -16,8 +16,8 @@ open Environ
 (*s Reduction functions *)
 
 val whd_betaiotazeta        : constr -> constr
-val whd_betadeltaiota       : env -> constr -> constr
-val whd_betadeltaiota_nolet : env -> constr -> constr
+val whd_all       : env -> constr -> constr
+val whd_allnolet : env -> constr -> constr
 
 (************************************************************************)
 (*s conversion functions *)
diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml
index fa429755..11cd742b 100644
--- a/checker/safe_typing.ml
+++ b/checker/safe_typing.ml
@@ -7,12 +7,14 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Cic
 open Names
 open Environ
 
+let pr_dirpath dp = str (DirPath.to_string dp)
+
 (************************************************************************)
 (*
  * Global environment
@@ -33,28 +35,23 @@ let full_add_module dp mb univs digest =
   genv := add_digest env dp digest
 
 (* Check that the engagement expected by a library extends the initial one *)
-let check_engagement env (expected_impredicative_set,expected_type_in_type) =
-  let impredicative_set,type_in_type = Environ.engagement env in
+let check_engagement env expected_impredicative_set =
+  let impredicative_set = Environ.engagement env in
   begin
     match impredicative_set, expected_impredicative_set with
     | PredicativeSet, ImpredicativeSet ->
-        Errors.error "Needs option -impredicative-set."
+        CErrors.error "Needs option -impredicative-set."
     | _ -> ()
   end;
-  begin
-    match type_in_type, expected_type_in_type with
-    | StratifiedType, TypeInType ->
-        Errors.error "Needs option -type-in-type."
-    | _ -> ()
-  end
+  ()
 
 (* Libraries = Compiled modules *)
 
 let report_clash f caller dir =
   let msg =
-    str "compiled library " ++ str(DirPath.to_string caller) ++
+    str "compiled library " ++ pr_dirpath caller ++
     spc() ++ str "makes inconsistent assumptions over library" ++ spc() ++
-    str(DirPath.to_string dir) ++ fnl() in
+    pr_dirpath dir ++ fnl() in
   f msg
 
 
@@ -79,7 +76,7 @@ let stamp_library file digest = ()
    warning is issued in case of mismatch *)
 let import file clib univs digest =
   let env = !genv in
-  check_imports msg_warning clib.comp_name env clib.comp_deps;
+  check_imports Feedback.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
@@ -91,7 +88,7 @@ let import file clib univs digest =
 (* When the module is admitted, digests *must* match *)
 let unsafe_import file clib univs digest =
   let env = !genv in
-  if !Flags.debug then check_imports msg_warning clib.comp_name env clib.comp_deps
+  if !Flags.debug then check_imports Feedback.msg_warning clib.comp_name env clib.comp_deps
   else 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/subtyping.ml b/checker/subtyping.ml
index e4192257..7eae9b83 100644
--- a/checker/subtyping.ml
+++ b/checker/subtyping.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 (*i*)
-open Errors
+open CErrors
 open Util
 open Names
 open Cic
@@ -103,7 +103,7 @@ let check_inductive  env mp1 l info1 mib2 spec2 subst1 subst2=
   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 MutInd.equal (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);
@@ -302,7 +302,7 @@ 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 (Errors.error (
+	  ignore (CErrors.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 " ^
@@ -313,7 +313,7 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 =
       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 (Errors.error (
+      ignore (CErrors.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 " ^
diff --git a/checker/term.ml b/checker/term.ml
index 6487d1a1..591348cb 100644
--- a/checker/term.ml
+++ b/checker/term.ml
@@ -8,7 +8,7 @@
 
 (* This module instantiates the structure of generic deBruijn terms to Coq *)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Esubst
@@ -222,24 +222,29 @@ 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
+    | LocalAssum _ :: hyps -> nhyps (1+acc) hyps
+    | LocalDef _ :: hyps -> nhyps acc hyps in
   nhyps 0 hyps
 let fold_rel_context f l ~init = List.fold_right f l init
 
-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_decl f = function
+  | LocalAssum (n, typ) as decl ->
+     let typ' = f typ in
+     if typ' == typ then decl else
+       LocalAssum (n, typ')
+  | LocalDef (n, body, typ) as decl ->
+     let body' = f body in
+     let typ' = f typ in
+     if body' == body && typ' == typ then decl else
+       LocalDef (n, body', typ')
+
+let map_rel_context f =
+  List.smartmap (map_rel_decl f)
 
 let extended_rel_list n hyps =
   let rec reln l p = function
-    | (_,None,_) :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps
-    | (_,Some _,_) :: hyps -> reln l (p+1) hyps
+    | LocalAssum _ :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps
+    | LocalDef _ :: hyps -> reln l (p+1) hyps
     | [] -> l
   in
   reln [] 1 hyps
@@ -272,8 +277,8 @@ let decompose_lam_n_assum n =
   let rec lamdec_rec l n 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
+    | Lambda (x,t,c)  -> lamdec_rec (LocalAssum (x,t) :: l) (n-1) c
+    | LetIn (x,b,t,c) -> lamdec_rec (LocalDef (x,b,t) :: l) n c
     | Cast (c,_,_)      -> lamdec_rec l n c
     | c -> error "decompose_lam_n_assum: not enough abstractions"
   in
@@ -282,18 +287,18 @@ let decompose_lam_n_assum n =
 (* Iterate products, with or without lets *)
 
 (* Constructs either [(x:t)c] or [[x=b:t]c] *)
-let mkProd_or_LetIn (na,body,t) c =
-  match body with
-    | None -> Prod (na, t, c)
-    | Some b -> LetIn (na, b, t, c)
+let mkProd_or_LetIn decl c =
+  match decl with
+    | LocalAssum (na,t) -> Prod (na, t, c)
+    | LocalDef (na,b,t) -> LetIn (na, b, t, c)
 
 let it_mkProd_or_LetIn   = List.fold_left (fun c d -> mkProd_or_LetIn d c)
 
 let decompose_prod_assum =
   let rec prodec_rec l c =
     match c with
-    | Prod (x,t,c)    -> prodec_rec ((x,None,t) :: l) c
-    | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t) :: l) c
+    | Prod (x,t,c)    -> prodec_rec (LocalAssum (x,t) :: l) c
+    | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) c
     | Cast (c,_,_)    -> prodec_rec l c
     | _               -> l,c
   in
@@ -305,8 +310,8 @@ let decompose_prod_n_assum n =
   let rec prodec_rec l n 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
+    | Prod (x,t,c)    -> prodec_rec (LocalAssum (x,t) :: l) (n-1) c
+    | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) (n-1) c
     | Cast (c,_,_)    -> prodec_rec l n c
     | c -> error "decompose_prod_n_assum: not enough assumptions"
   in
@@ -324,8 +329,8 @@ let mkArity (sign,s) = it_mkProd_or_LetIn (Sort s) sign
 let destArity =
   let rec prodec_rec l c =
     match c with
-    | Prod (x,t,c)    -> prodec_rec ((x,None,t)::l) c
-    | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c
+    | Prod (x,t,c)    -> prodec_rec (LocalAssum (x,t)::l) c
+    | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t)::l) c
     | Cast (c,_,_)    -> prodec_rec l c
     | Sort s          -> l,s
     | _               -> anomaly ~label:"destArity" (Pp.str "not an arity")
diff --git a/checker/term.mli b/checker/term.mli
index ab488b2b..0af83e05 100644
--- a/checker/term.mli
+++ b/checker/term.mli
@@ -35,12 +35,13 @@ 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_rel_decl : (constr -> constr) -> rel_declaration -> rel_declaration
 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
 val decompose_lam : constr -> (name * constr) list * constr
 val decompose_lam_n_assum : int -> constr -> rel_context * constr
-val mkProd_or_LetIn : name * constr option * constr -> constr -> constr
+val mkProd_or_LetIn : rel_declaration -> constr -> constr
 val it_mkProd_or_LetIn : constr -> rel_context -> constr
 val decompose_prod_assum : constr -> rel_context * constr
 val decompose_prod_n_assum : int -> constr -> rel_context * constr
diff --git a/checker/typeops.ml b/checker/typeops.ml
index d49c40a8..173e19ce 100644
--- a/checker/typeops.ml
+++ b/checker/typeops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Cic
@@ -33,7 +33,7 @@ let check_constraints cst env =
 
 (* 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
+  match whd_all env ty with
     | Sort s -> (c,s)
     | _ -> error_not_type env j
 
@@ -62,7 +62,7 @@ let judge_of_type u = Sort (Type (Univ.super u))
 
 let judge_of_relative env n =
   try
-    let (_,_,typ) = lookup_rel n env in
+    let LocalAssum (_,typ) | LocalDef (_,_,typ) = lookup_rel n env in
     lift n typ
   with Not_found ->
     error_unbound_rel env n
@@ -92,7 +92,7 @@ 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 kn)
+      failwith ("Cannot find constant: "^Constant.to_string kn)
   in
   let ty, cu = type_of_constant_knowing_parameters env cst paramstyp in
   let () = check_constraints cu env in
@@ -107,7 +107,7 @@ let judge_of_apply env (f,funj) argjv =
   let rec apply_rec n typ = function
     | [] -> typ
     | (h,hj)::restjl ->
-        (match whd_betadeltaiota env typ with
+        (match whd_all env typ with
           | Prod (_,c1,c2) ->
 	      (try conv_leq env hj c1
 	      with NotConvertible ->
@@ -128,7 +128,7 @@ let sort_of_product env domsort rangsort =
     | (Prop _,  Prop Pos) -> rangsort
     (* Product rule (Type,Set,?) *)
     | (Type u1, Prop Pos) ->
-        if fst (engagement env) = ImpredicativeSet then
+        if engagement env = ImpredicativeSet then
           (* Rule is (Type,Set,Set) in the Set-impredicative calculus *)
           rangsort
         else
@@ -178,7 +178,7 @@ 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))
+      failwith ("Cannot find inductive: "^MutInd.to_string (fst ind))
   in
   type_of_inductive_knowing_parameters env (specif,u) paramstyp
 
@@ -192,7 +192,7 @@ let judge_of_constructor env (c,u) =
   let specif =
     try lookup_mind_specif env ind
     with Not_found ->
-      failwith ("Cannot find inductive: "^string_of_mind (fst ind))
+      failwith ("Cannot find inductive: "^MutInd.to_string (fst ind))
   in
   type_of_constructor (c,u) specif
 
@@ -223,7 +223,7 @@ let judge_of_projection env p c ct =
     try find_rectype env ct
     with Not_found -> error_case_not_inductive env (c, ct)
   in
-    assert(eq_mind pb.proj_ind (fst ind));
+    assert(MutInd.equal pb.proj_ind (fst ind));
     let ty = subst_instance_constr u pb.proj_type in
       substl (c :: List.rev args) ty
 
@@ -296,13 +296,13 @@ let rec execute env cstr =
 
     | Lambda (name,c1,c2) ->
         let _ = execute_type env c1 in
-	let env1 = push_rel (name,None,c1) env in
+	let env1 = push_rel (LocalAssum (name,c1)) env in
         let j' = execute env1 c2 in
         Prod(name,c1,j')
 
     | Prod (name,c1,c2) ->
         let varj = execute_type env c1 in
-	let env1 = push_rel (name,None,c1) env in
+	let env1 = push_rel (LocalAssum (name,c1)) env in
         let varj' = execute_type env1 c2 in
 	Sort (sort_of_product env varj varj')
 
@@ -314,7 +314,7 @@ let rec execute env cstr =
           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
+        let env1 = push_rel (LocalDef (name,c1,c2)) env in
         let j' = execute env1 c3 in
         subst1 c1 j'
 
@@ -378,10 +378,10 @@ let infer_type env constr = execute_type env constr
 let check_ctxt env rels =
   fold_rel_context (fun d env ->
     match d with
-        (_,None,ty) ->
+      | LocalAssum (_,ty) ->
           let _ = infer_type env ty in
           push_rel d env
-      | (_,Some bd,ty) ->
+      | LocalDef (_,bd,ty) ->
           let j1 = infer env bd in
           let _ = infer env ty in
           conv_leq env j1 ty;
@@ -399,9 +399,9 @@ let check_polymorphic_arity env params par =
   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 ->
+        Some u::pl, LocalAssum (na,ty)::params ->
           check_kind env ty u;
-          check_p (push_rel (na,None,ty) env) pl params
+          check_p (push_rel (LocalAssum (na,ty)) env) pl params
       | None::pl,d::params -> check_p (push_rel d env) pl params
       | [], _ -> ()
       | _ -> failwith "check_poly: not the right number of params" in
diff --git a/checker/univ.ml b/checker/univ.ml
index cb2eaced..668f3a05 100644
--- a/checker/univ.ml
+++ b/checker/univ.ml
@@ -14,7 +14,7 @@
 (* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey *)
 
 open Pp
-open Errors
+open CErrors
 open Util
 
 (* Universes are stratified by a partial ordering $\le$.
@@ -33,7 +33,7 @@ module type Hashconsed =
 sig
   type t
   val hash : t -> int
-  val equal : t -> t -> bool
+  val eq : t -> t -> bool
   val hcons : t -> t
 end
 
@@ -51,7 +51,7 @@ struct
     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
+    let eq l1 l2 = match l1, l2 with
     | Nil, Nil -> true
     | Cons (x1, _, l1), Cons (x2, _, l2) -> x1 == x2 && l1 == l2
     | _ -> false
@@ -131,7 +131,7 @@ module HList = struct
   let rec remove x = function
   | Nil -> nil
   | Cons (y, _, l) ->
-    if H.equal x y then l
+    if H.eq x y then l
     else cons y (remove x l)
 
   end
@@ -229,7 +229,7 @@ module Level = struct
     type _t = t
     type t = _t
     type u = unit
-    let equal x y = x.hash == y.hash && RawLevel.hequal x.data y.data
+    let eq x y = x.hash == y.hash && RawLevel.hequal x.data y.data
     let hash x = x.hash
     let hashcons () x =
       let data' = RawLevel.hcons x.data in
@@ -320,7 +320,7 @@ struct
       let hashcons hdir (b,n as x) = 
 	let b' = hdir b in 
 	  if b' == b then x else (b',n)
-      let equal l1 l2 =
+      let eq l1 l2 =
         l1 == l2 || 
         match l1,l2 with
 	| (b,n), (b',n') -> b == b' && n == n'
@@ -339,7 +339,7 @@ struct
       let hcons =
         Hashcons.simple_hcons H.generate H.hcons Level.hcons
       let hash = ExprHash.hash
-      let equal x y = x == y ||
+      let eq x y = x == y ||
         (let (u,n) = x and (v,n') = y in
            Int.equal n n' && Level.equal u v)
 
@@ -1089,7 +1089,7 @@ struct
 	  a
 	end
 
-    let equal t1 t2 =
+    let eq t1 t2 =
       t1 == t2 ||
 	(Int.equal (Array.length t1) (Array.length t2) &&
 	   let rec aux i =
diff --git a/checker/values.ml b/checker/values.ml
index c14e9223..c175aed6 100644
--- a/checker/values.ml
+++ b/checker/values.ml
@@ -13,7 +13,7 @@
 To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli
 with a copy we maintain here:
 
-MD5 7c050ff1db22f14ee3a4c44aae533082 checker/cic.mli
+MD5 6466d8cc443b5896cb905776df0cc49e  checker/cic.mli
 
 *)
 
@@ -154,8 +154,8 @@ and v_prec = Tuple ("prec_declaration",
 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_rdecl = v_sum "rel_declaration" 0 [| [|v_name; v_constr|];               (* LocalAssum *)
+                                           [|v_name; v_constr; v_constr|] |]   (* LocalDef *)
 let v_rctxt = List v_rdecl
 
 let v_section_ctxt = v_enum "emptylist" 1
@@ -194,8 +194,7 @@ let v_lazy_constr =
 (** kernel/declarations *)
 
 let v_impredicative_set = v_enum "impr-set" 2
-let v_type_in_type = v_enum "type-in-type" 2
-let v_engagement = v_tuple "eng" [|v_impredicative_set; v_type_in_type|]
+let v_engagement = v_impredicative_set
 
 let v_pol_arity =
   v_tuple "polymorphic_arity" [|List(Opt v_level);v_univ|]
@@ -213,6 +212,9 @@ let v_projbody =
 	    v_tuple "proj_eta" [|v_constr;v_constr|];
 	    v_constr|]
 
+let v_typing_flags =
+  v_tuple "typing_flags" [|v_bool; v_bool|]
+
 let v_cb = v_tuple "constant_body"
   [|v_section_ctxt;
     v_cst_def;
@@ -221,7 +223,8 @@ let v_cb = v_tuple "constant_body"
     v_bool;
     v_context;
     Opt v_projbody;
-    v_bool|]
+    v_bool;
+    v_typing_flags|]
 
 let v_recarg = v_sum "recarg" 1 (* Norec *)
   [|[|v_ind|] (* Mrec *);[|v_ind|] (* Imbr *)|]
@@ -270,7 +273,8 @@ let v_ind_pack = v_tuple "mutual_inductive_body"
     v_rctxt;
     v_bool;
     v_context;
-    Opt v_bool|]
+    Opt v_bool;
+    v_typing_flags|]
 
 let v_with =
   Sum ("with_declaration_body",0,
diff --git a/checker/votour.ml b/checker/votour.ml
index 78978bb2..48f9f45e 100644
--- a/checker/votour.ml
+++ b/checker/votour.ml
@@ -10,6 +10,26 @@ open Values
 
 (** {6 Interactive visit of a vo} *)
 
+let rec read_num max =
+  let quit () =
+    Printf.printf "\nGoodbye!\n%!";
+    exit 0 in
+  Printf.printf "# %!";
+  let l = try read_line () with End_of_file -> quit () in
+  if l = "u" then None
+  else if l = "x" then quit ()
+  else
+    try
+      let v = int_of_string l in
+      if v < 0 || v >= max then
+        let () =
+          Printf.printf "Out-of-range input! (only %d children)\n%!" max in
+        read_num max
+      else Some v
+    with Failure "int_of_string" ->
+      Printf.printf "Unrecognized input! <n> enters the <n>-th child, u goes up 1 level, x exits\n%!";
+      read_num max
+
 type 'a repr =
 | INT of int
 | STRING of string
@@ -22,6 +42,7 @@ sig
   val input : in_channel -> obj
   val repr : obj -> obj repr
   val size : obj -> int
+  val oid : obj -> int option
 end
 
 module ReprObj : S =
@@ -45,6 +66,7 @@ struct
     else INT (Obj.magic obj)
 
   let size (_, p) = CObj.shared_size_of_pos p
+  let oid _ = None
 end
 
 module ReprMem : S =
@@ -97,6 +119,9 @@ struct
     let _ = init_size seen obj in
     obj
 
+  let oid = function
+  | Int _ | Atm _ | Fun _ -> None
+  | Ptr p -> Some p
 end
 
 module Visit (Repr : S) :
@@ -149,9 +174,13 @@ let rec get_details v o = match v, Repr.repr o with
   |Annot (s,v), _ -> get_details v o
   |_ -> ""
 
+let get_oid obj = match Repr.oid obj with
+| None -> ""
+| Some id -> Printf.sprintf " [0x%08x]" id
+
 let node_info (v,o,p) =
   get_name ~extra:true v ^ get_details v o ^
-    " (size "^ string_of_int (Repr.size o)^"w)"
+    " (size "^ string_of_int (Repr.size o)^"w)" ^ get_oid o
 
 (** Children of a block : type, object, position.
     For lists, we collect all elements of the list at once *)
@@ -246,15 +275,13 @@ let rec visit v o pos =
     (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'
+    match read_num (Array.length children) with
+    | None -> let info = pop () in visit info.typ info.obj info.pos
+    | Some child ->
+       let v',o',pos' = children.(child) 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
@@ -341,13 +368,13 @@ let visit_vo f =
       let size = if Sys.word_size = 64 then header.size64 else header.size32 in
       Printf.printf "  %d: %s, starting at byte %d (size %iw)\n" i name pos size)
       segments;
-    Printf.printf "# %!";
-    let l = read_line () in
-    let seg = int_of_string l in
-    seek_in ch segments.(seg).pos;
-    let o = Repr.input ch in
-    let () = Visit.init () in
-    Visit.visit segments.(seg).typ o []
+    match read_num (Array.length segments) with
+    | Some seg ->
+       seek_in ch segments.(seg).pos;
+       let o = Repr.input ch in
+       let () = Visit.init () in
+       Visit.visit segments.(seg).typ o []
+    | None -> ()
   done
 
 let main =
diff --git a/config/coq_config.mli b/config/coq_config.mli
index f2500593..c171bd35 100644
--- a/config/coq_config.mli
+++ b/config/coq_config.mli
@@ -14,12 +14,7 @@ val datadir : string option (* where extra data files are installed *)
 val docdir : string     (* where the doc is installed *)
 
 val ocaml : string      (* names of ocaml binaries *)
-val ocamlc : string
-val ocamlopt : string
-val ocamlmklib : string
-val ocamldoc : string
-val ocamldep : string
-val ocamlyacc : string
+val ocamlfind : string
 val ocamllex : string
 
 val camlbin : string    (* base directory of OCaml binaries *)
@@ -37,7 +32,7 @@ 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 osdeplibs : string  (* OS dependent link options for ocamlc *)
 val vmbyteflags : string list (* -custom/-dllib -lcoqrun *)
 
 
@@ -56,7 +51,7 @@ val exec_extension : string (* "" under Unix, ".exe" under MS-windows *)
 val with_geoproof : bool ref (* to (de)activate functions specific to Geoproof with Coqide *)
 
 val browser : string
-(** default web browser to use, may be overriden by environment
+(** default web browser to use, may be overridden by environment
     variable COQREMOTEBROWSER *)
 
 val has_coqide : string
@@ -67,6 +62,7 @@ val natdynlinkflag : string (* special cases of natdynlink (e.g. MacOS 10.5) *)
 
 val wwwcoq : string
 val wwwrefman : string
+val wwwbugtracker : string
 val wwwstdlib : string
 val localwwwrefman : string
 
diff --git a/configure.ml b/configure.ml
index 7ab19709..99f5ae54 100644
--- a/configure.ml
+++ b/configure.ml
@@ -11,11 +11,11 @@
 #load "str.cma"
 open Printf
 
-let coq_version = "8.5"
-let coq_macos_version = "8.5.0" (** "[...] should be a string comprised of
-three non-negative, period-separed integers [...]" *)
-let vo_magic = 8500
-let state_magic = 58500
+let coq_version = "8.6"
+let coq_macos_version = "8.6.00" (** "[...] should be a string comprised of
+three non-negative, period-separated integers [...]" *)
+let vo_magic = 8600
+let state_magic = 58600
 let distributed_exec = ["coqtop";"coqc";"coqchk";"coqdoc";"coqmktop";"coqworkmgr";
 "coqdoc";"coq_makefile";"coq-tex";"gallina";"coqwc";"csdpcert";"coqdep"]
 
@@ -178,6 +178,19 @@ let which prog =
 let program_in_path prog =
   try let _ = which prog in true with Not_found -> false
 
+(** As per bug #4828, ocamlfind on Windows/Cygwin barfs if you pass it
+    a quoted path to camlpXo via -pp.  So we only quote camlpXo on not
+    Windows, and warn on Windows if the path contains spaces *)
+let contains_suspicious_characters str =
+  List.fold_left (fun b ch -> String.contains str ch || b) false [' '; '\t']
+
+let win_aware_quote_executable str =
+  if not (os_type_win32 || os_type_cygwin) then
+    sprintf "%S" str
+  else
+    let _ = if contains_suspicious_characters str then
+      printf "*Warning* The string %S contains suspicious characters; ocamlfind might fail\n" str in
+    Str.global_replace (Str.regexp "\\\\") "/" str
 
 (** * Date *)
 
@@ -236,7 +249,7 @@ module Prefs = struct
   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 ocamlfindcmd = ref (None : string option)
   let lablgtkdir = ref (None : string option)
   let usecamlp5 = ref true
   let camlp5dir = ref (None : string option)
@@ -251,7 +264,6 @@ module Prefs = struct
   let debug = ref false
   let profile = ref false
   let annotate = ref false
-  let makecmd = ref "make"
   let nativecompiler = ref (not (os_type_win32 || os_type_cygwin))
   let coqwebsite = ref "http://coq.inria.fr/"
   let force_caml_version = ref false
@@ -290,8 +302,8 @@ let args_options = Arg.align [
     "<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 binaries";
+  "-ocamlfind", arg_string_option Prefs.ocamlfindcmd,
+    "<dir> Specifies the ocamlfind command to use";
   "-lablgtkdir", arg_string_option Prefs.lablgtkdir,
     "<dir> Specifies the path to the Lablgtk library";
   "-usecamlp5", Arg.Set Prefs.usecamlp5,
@@ -329,14 +341,14 @@ let args_options = Arg.align [
     " 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";
+  "-makecmd", Arg.String (fun _ -> printf "Warning: obsolete -makecmd option\n"),
+    "<command> Obsolete: name of GNU Make command";
   "-native-compiler", arg_bool Prefs.nativecompiler,
     "(yes|no) Compilation to native code for conversion and normalization";
   "-coqwebsite", Arg.Set_string Prefs.coqwebsite,
     " URL of the coq website";
   "-force-caml-version", Arg.Set Prefs.force_caml_version,
-    "Force OCaml version";
+    " Force OCaml version";
 ]
 
 let parse_args () =
@@ -352,42 +364,18 @@ let _ = parse_args ()
 (** Default OCaml binaries *)
 
 type camlexec =
- { mutable byte : string;
-   mutable opt : string;
+ { mutable find : string;
    mutable top : string;
-   mutable mklib : string;
-   mutable dep : string;
-   mutable doc : string;
-   mutable lex : string;
-   mutable yacc : string }
-
-(* TODO: autodetect .opt binaries ? *)
+   mutable lex : string; }
 
 let camlexec =
-  { byte = "ocamlc";
-    opt = "ocamlopt";
+  { find = "ocamlfind";
     top = "ocaml";
-    mklib = "ocamlmklib";
-    dep = "ocamldep";
-    doc = "ocamldoc";
-    lex = "ocamllex";
-    yacc = "ocamlyacc" }
-
-let reset_caml_byte c o = c.byte <- o
-let reset_caml_opt c o = c.opt <- o
-let reset_caml_doc c o = c.doc <- o
+    lex = "ocamllex"; }
+
 let reset_caml_lex c o = c.lex <- o
-let reset_caml_dep c o = c.dep <- o
-
-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
+let reset_caml_top c o = c.top <- o
+let reset_caml_find c o = c.find <- o
 
 let coq_debug_flag = if !Prefs.debug then "-g" else ""
 let coq_profile_flag = if !Prefs.profile then "-p" else ""
@@ -442,23 +430,11 @@ let dll = if os_type_win32 then ".dll" else ".so"
 
 let vcs =
   let git_dir = try Sys.getenv "GIT_DIR" with Not_found -> ".git" in
-  if dir_exists git_dir then "git"
+  if Sys.file_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 =
@@ -471,32 +447,28 @@ let browser =
 (** * OCaml programs *)
 
 let camlbin, caml_version, camllib =
-  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
-        let dir = Filename.dirname camlc in
-        if not arch_win32 then rebase_camlexec dir camlexec; (* win32: TOCHECK *)
-        dir, 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 () = match !Prefs.ocamlfindcmd with
+    | Some cmd -> reset_caml_find camlexec cmd
+    | None ->
+       try reset_caml_find camlexec (which camlexec.find)
+       with Not_found ->
+	 die (sprintf "Error: cannot find '%s' in your path!\n" camlexec.find ^
+		"Please adjust your path or use the -ocamlfind option of ./configure")
   in
-  let camlcopt = camlc ^ ".opt" in
-  let camlc =
-    if is_executable camlcopt then begin
-      reset_caml_byte camlexec (camlexec.byte ^ ".opt");
-      camlcopt
-    end
-    else if is_executable camlc then
-      camlc
-    else
-      die ("Error: cannot find the executable '"^camlc^"'.") in
-  let caml_version, _ = run camlc ["-version"] in
-  let camllib, _ = run camlc ["-where"] in
-  camlbin, caml_version, camllib
+  if not (is_executable camlexec.find)
+  then die ("Error: cannot find the executable '"^camlexec.find^"'.")
+  else
+    let caml_version, _ = run camlexec.find ["ocamlc";"-version"] in
+    let camllib, _ = run camlexec.find ["printconf";"stdlib"] in
+    let camlbin = (* TODO beurk beurk beurk *)
+      Filename.dirname (Filename.dirname camllib) / "bin/" in
+    let () =
+      if is_executable (camlbin / "ocamllex")
+      then reset_caml_lex camlexec (camlbin / "ocamllex") in
+    let () =
+      if is_executable (camlbin / "ocaml")
+      then reset_caml_top camlexec (camlbin / "ocaml") in
+    camlbin, caml_version, camllib
 
 let camlp4compat = "-loc loc"
 
@@ -515,7 +487,7 @@ let caml_version_nums =
          "Is it installed properly?")
 
 let check_caml_version () =
-  if caml_version_nums >= [3;12;1] then
+  if caml_version_nums >= [4;1;0] then
     if caml_version_nums = [4;2;0] && not !Prefs.force_caml_version then
       die ("Your version of OCaml is 4.02.0 which suffers from a bug inducing\n" ^
         "very slow compilation times. If you still want to use it, use \n" ^
@@ -527,7 +499,7 @@ let check_caml_version () =
     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."
+      die "You need OCaml 4.01 or later."
 
 let _ = check_caml_version ()
 
@@ -544,12 +516,8 @@ let camltag = match caml_version_list with
 (* Convention: we use camldir as a prioritary location for camlpX, if given *)
 
 let which_camlpX base =
-  match !Prefs.camldir with
-  | Some dir ->
-    let file = Filename.concat dir base in
-    if is_executable file then file else which base
-  | None ->
-    which base
+  let file = Filename.concat camlbin base in
+  if is_executable file then file else which base
 
 (* TODO: camlp5dir should rather be the *binary* location, just as camldir *)
 (* TODO: remove the late attempts at finding gramlib.cma *)
@@ -558,51 +526,47 @@ exception NoCamlp5
 
 let check_camlp5 testcma = match !Prefs.camlp5dir with
   | Some dir ->
-    if Sys.file_exists (dir/testcma) then dir
+    if Sys.file_exists (dir/testcma) then
+      let camlp5o =
+        try which_camlpX "camlp5o"
+        with Not_found -> die "Error: cannot find Camlp5 binaries in path.\n" in
+      dir, camlp5o
     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 then 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 () =
-  try
-    let camlp5o = which_camlpX "camlp5o" in
-    let version_line, _ = run ~err:StdOut camlp5o ["-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; camlp5o, version
-    | _ -> failwith "bad version"
-  with
-  | Not_found -> die "Error: cannot find Camlp5 binaries in path.\n"
-  | _ -> die "Error: unsupported Camlp5 (version < 5.01 or unrecognized).\n"
+    try
+      let camlp5o = which_camlpX "camlp5o" in
+      let dir,_ = tryrun camlp5o ["-where"] in
+      dir, camlp5o
+    with Not_found ->
+      let () = printf "No Camlp5 installation found." in
+      let () = printf "Looking for Camlp4 instead...\n" in
+      raise NoCamlp5
+
+let check_camlp5_version camlp5o =
+  let version_line, _ = run ~err:StdOut camlp5o ["-v"] in
+  let version = List.nth (string_split ' ' version_line) 2 in
+  match string_split '.' version with
+  | major::minor::_ when s2i major > 6 || (s2i major, s2i minor) >= (6,6) ->
+    printf "You have Camlp5 %s. Good!\n" version; version
+  | _ -> die "Error: unsupported Camlp5 (version < 6.06 or unrecognized).\n"
+
+let check_caml_version_for_camlp4 () =
+  if caml_version_nums = [4;1;0] && !Prefs.debug && not !Prefs.force_caml_version then
+    die ("Your version of OCaml is detected to be 4.01.0 which fails to compile\n" ^
+         "Coq in -debug mode with Camlp4. Remove -debug option or use a different\n" ^
+         "version of OCaml or use Camlp5, or bypass this test by using option\n" ^
+         "-force-caml-version.\n")
 
 let config_camlpX () =
   try
     if not !Prefs.usecamlp5 then raise NoCamlp5;
     let camlp5mod = "gramlib" in
-    let camlp5libdir = check_camlp5 (camlp5mod^".cma") in
-    let camlp5o, camlp5_version = check_camlp5_version () in
+    let camlp5libdir, camlp5o = check_camlp5 (camlp5mod^".cma") in
+    let camlp5_version = check_camlp5_version camlp5o in
     "camlp5", camlp5o, Filename.dirname camlp5o, camlp5libdir, camlp5mod, camlp5_version
   with NoCamlp5 ->
     (* We now try to use Camlp4, either by explicit choice or
@@ -615,6 +579,7 @@ let config_camlpX () =
       let camlp4orf = which_camlpX "camlp4orf" in
       let version_line, _ = run ~err:StdOut camlp4orf ["-v"] in
       let camlp4_version = List.nth (string_split ' ' version_line) 2 in
+      check_caml_version_for_camlp4 ();
       "camlp4", camlp4orf, Filename.dirname camlp4orf, camlp4libdir, camlp4mod, camlp4_version
     with _ -> die "No Camlp4 installation found.\n"
 
@@ -646,60 +611,29 @@ let msg_no_dynlink_cmxa () =
   printf "and then run ./configure -natdynlink no\n"
 
 let check_native () =
-  if !Prefs.byteonly then raise Not_found;
-  let camloptopt = camlexec.opt ^ ".opt" in
-  if (is_executable camloptopt || program_in_path camloptopt) then
-    reset_caml_opt camlexec camloptopt
-  else if not (is_executable camlexec.opt || program_in_path camlexec.opt) then
-    (msg_no_ocamlopt (); raise Not_found);
-  if not (Sys.file_exists (fullcamlpXlibdir/camlpXmod^".cmxa")) then
-    (msg_no_camlpX_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 () = if !Prefs.byteonly then raise Not_found in
+  let version, _ = tryrun camlexec.find ["opt";"-version"] in
+  if version = "" then let () = msg_no_ocamlopt () in raise Not_found
+  else if not (Sys.file_exists (fullcamlpXlibdir/camlpXmod^".cmxa"))
+  then let () = msg_no_camlpX_cmxa () in raise Not_found
+  else if fst (tryrun camlexec.find ["query";"dynlink"]) = ""
+  then let () = msg_no_dynlink_cmxa () in raise Not_found
+  else
+    let () =
+      if version <> caml_version then
+	printf
+	  "Warning: Native and bytecode compilers do not have the same version!\n"
+    in printf "You have native-code compilation. Good!\n"
 
 let best_compiler =
   try check_native (); "opt" with Not_found -> "byte"
 
-let _ =
-  let camllexopt = camlexec.lex ^ ".opt" in
-  if is_executable camllexopt || program_in_path camllexopt then
-    reset_caml_lex camlexec camllexopt
-
-let _ =
-  let camldepopt = camlexec.dep ^ ".opt" in
-  if is_executable camldepopt || program_in_path camldepopt then
-    reset_caml_dep camlexec camldepopt
-
-let _ =
-  let camldocopt = camlexec.doc ^ ".opt" in
-  if is_executable camldocopt || program_in_path camldocopt then
-    reset_caml_doc camlexec camldocopt
-
 (** * 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"
+  if hasnatdynlink then "true" else "false"
 
 
 (** * OS dependent libraries *)
@@ -719,10 +653,18 @@ let operating_system, osdeplibs =
 
 (** * lablgtk2 and CoqIDE *)
 
+type source = Manual | OCamlFind | Stdlib
+
+let get_source = function
+| Manual -> "manually provided"
+| OCamlFind -> "via ocamlfind"
+| Stdlib -> "in OCaml library"
+
 (** Is some location a suitable LablGtk2 installation ? *)
 
-let check_lablgtkdir ?(fatal=false) msg dir =
+let check_lablgtkdir ?(fatal=false) src dir =
   let yell msg = if fatal then die msg else (printf "%s\n" msg; false) in
+  let msg = get_source src 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
@@ -736,11 +678,11 @@ let check_lablgtkdir ?(fatal=false) msg dir =
 let get_lablgtkdir () =
   match !Prefs.lablgtkdir with
   | Some dir ->
-    let msg = "manually provided" in
+    let msg = Manual in
     if check_lablgtkdir ~fatal:true msg dir then dir, msg
-    else "", ""
+    else "", msg
   | None ->
-    let msg = "via ocamlfind" in
+    let msg = OCamlFind in
     let d1,_ = tryrun "ocamlfind" ["query";"lablgtk2.sourceview2"] in
     if d1 <> "" && check_lablgtkdir msg d1 then d1, msg
     else
@@ -748,10 +690,34 @@ let get_lablgtkdir () =
       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 msg = Stdlib in
         let d3 = camllib^"/lablgtk2" in
         if check_lablgtkdir msg d3 then d3, msg
-        else "", ""
+        else "", msg
+
+(** Detect and/or verify the Lablgtk2 version *)
+
+let check_lablgtk_version src dir = match src with
+| Manual | Stdlib ->
+  let test accu f =
+    if accu then
+      let test = sprintf "grep -q -w %s %S/glib.mli" f dir in
+      Sys.command test = 0
+    else false
+  in
+  let heuristics = [
+    "convert_with_fallback";
+    "wrap_poll_func"; (** Introduced in lablgtk 2.16 *)
+  ] in
+  let ans = List.fold_left test true heuristics in
+  if ans then printf "Warning: could not check the version of lablgtk2.\n";
+  (ans, "an unknown version")
+| OCamlFind ->
+  let v, _ = tryrun "ocamlfind" ["query"; "-format"; "%v"; "lablgtk2"] in
+  try
+    let vi = List.map s2i (numeric_prefix_list v) in
+    ([2; 16] <= vi, v)
+  with _ -> (false, v)
 
 let pr_ide = function No -> "no" | Byte -> "only bytecode" | Opt -> "native"
 
@@ -775,9 +741,9 @@ 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");
+  let (ok, version) = check_lablgtk_version via dir in
+  let found = sprintf "LablGtk2 found (%s, %s)" (get_source via) version in
+  if not ok then set_ide No (found^", but too old (required >= 2.16, found " ^ version ^ ")");
   (* 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");
@@ -830,20 +796,21 @@ let strip =
     if hasnatdynlink then "true" else "strip"
   else
     if !Prefs.profile || !Prefs.debug then "true" else begin
-    let _, all = run camlexec.byte ["-config"] in
+    let _, all = run camlexec.find ["ocamlc";"-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
+    if strip = "" then "strip" else strip
     end
 
 (** * md5sum command *)
 
 let md5sum =
-  if arch = "Darwin" then "md5 -q" else "md5sum"
+  if List.mem arch ["Darwin"; "FreeBSD"; "OpenBSD"]
+  then "md5 -q" else "md5sum"
 
 
 (** * Documentation : do we have latex, hevea, ... *)
@@ -968,7 +935,7 @@ let print_summary () =
   pr "\n";
   pr "  Architecture                : %s\n" arch;
   if operating_system <> "" then
-    pr "  Operating system          : %s\n" operating_system;
+    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;
@@ -1025,7 +992,7 @@ let write_dbg_wrapper f =
 let _ = write_dbg_wrapper "dev/ocamldebug-coq"
 
 
-(** * Build the config/coq_config.ml file (+ link to myocamlbuild_config.ml) *)
+(** * Build the config/coq_config.ml file *)
 
 let write_configml f =
   safe_remove f;
@@ -1047,12 +1014,7 @@ let write_configml f =
   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 "ocamlfind" camlexec.find;
   pr_s "ocamllex" camlexec.lex;
   pr_s "camlbin" camlbin;
   pr_s "camllib" camllib;
@@ -1081,6 +1043,7 @@ let write_configml f =
   pr "let with_geoproof = ref %B\n" !Prefs.geoproof;
   pr_s "browser" browser;
   pr_s "wwwcoq" !Prefs.coqwebsite;
+  pr_s "wwwbugtracker" (!Prefs.coqwebsite ^ "bugs/");
   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");
@@ -1097,15 +1060,18 @@ let write_configml f =
   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 "config/coq_config.ml"
 
-let _ = write_configml_my "config/coq_config.ml" "myocamlbuild_config.ml"
+(** * Symlinks or copies for the checker *)
 
+let _ =
+  let prog, args, prf =
+    if arch = "win32" then "cp", [], ""
+    else "ln", ["-s"], "../" in
+  List.iter (fun file ->
+    ignore(run "rm" ["-f"; "checker/"^file]);
+    ignore(run ~fatal:true prog (args @ [prf^"kernel/"^file;"checker/"^file])))
+  [ "esubst.ml"; "esubst.mli"; "names.ml"; "names.mli" ]
 
 (** * Build the config/Makefile file *)
 
@@ -1136,13 +1102,8 @@ let write_makefile f =
   pr "VERSION4MACOS=%s\n\n" coq_macos_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 "OCAMLFIND=%S\n" camlexec.find;
   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";
@@ -1152,8 +1113,6 @@ let write_makefile f =
   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";
@@ -1168,7 +1127,7 @@ let write_makefile f =
   pr "# Camlp4 : flavor, binaries, libraries ...\n";
   pr "# NB : avoid using CAMLP4LIB (conflict under Windows)\n";
   pr "CAMLP4=%s\n" camlpX;
-  pr "CAMLP4O=%S\n" camlpXo;
+  pr "CAMLP4O=%s\n" (win_aware_quote_executable camlpXo);
   pr "CAMLP4COMPAT=%s\n" camlp4compat;
   pr "MYCAMLP4LIB=%S\n\n" camlpXlibdir;
   pr "# Your architecture\n";
diff --git a/coq-win32.itarget b/coq-win32.itarget
deleted file mode 100644
index 9e2c7a2b..00000000
--- a/coq-win32.itarget
+++ /dev/null
@@ -1,2 +0,0 @@
-binariesopt
-plugins/pluginsdyn.otarget
diff --git a/coq.itarget b/coq.itarget
deleted file mode 100644
index dd8b2590..00000000
--- a/coq.itarget
+++ /dev/null
@@ -1,8 +0,0 @@
-# NB: for the moment we start with bytecode compilation
-# for early error detection in .ml
-binariesbyte
-plugins/pluginsbyte.otarget
-binariesopt
-plugins/pluginsopt.otarget
-theories/theories.otarget
-plugins/pluginsvo.otarget
diff --git a/dev/README b/dev/README
index 5edf64c8..814f6095 100644
--- a/dev/README
+++ b/dev/README
@@ -45,3 +45,6 @@ Makefile.subdir: makefile dedicated to intensive work in a given subdirectory
 Makefile.devel: utilities to automatically launch coq in various states
 Makefile.common: used by other Makefiles
 objects.el: various development utilities at emacs level
+anomaly-traces-parser.el: a .emacs-ready elisp snippet to parse
+  location of Anomaly backtraces and jump to them conveniently from
+  the Emacs *compilation* output.
diff --git a/dev/base_include b/dev/base_include
index dac1f609..b09b6df2 100644
--- a/dev/base_include
+++ b/dev/base_include
@@ -8,6 +8,7 @@
 #directory "toplevel";;
 #directory "library";;
 #directory "kernel";;
+#directory "engine";;
 #directory "pretyping";;
 #directory "lib";;
 #directory "proofs";;
@@ -16,6 +17,7 @@
 #directory "grammar";;
 #directory "intf";;
 #directory "stm";;
+#directory "ltac";;
 
 #directory "+camlp4";; (* lazy solution: add both of camlp4/5 so that *)
 #directory "+camlp5";; (* Gramext is found in top_printers.ml *)
@@ -64,7 +66,7 @@ open Univ
 open Inductive
 open Indtypes
 open Cooking
-open Closure
+open CClosure
 open Reduction
 open Safe_typing
 open Declare
@@ -168,7 +170,7 @@ open Tacticals
 open Tactics
 open Eqschemes
 
-open Cerrors
+open ExplainErr
 open Class
 open Command
 open Indschemes
diff --git a/dev/make-macos-dmg.sh b/dev/build/osx/make-macos-dmg.sh
index 70889bad..b43ada90 100755
--- a/dev/make-macos-dmg.sh
+++ b/dev/build/osx/make-macos-dmg.sh
@@ -8,7 +8,7 @@ eval `opam config env`
 make distclean
 OUTDIR=$PWD/_install
 DMGDIR=$PWD/_dmg
-./configure -debug -prefix $OUTDIR
+./configure -debug -prefix $OUTDIR -native-compiler no
 VERSION=$(sed -n -e '/^let coq_version/ s/^[^"]*"\([^"]*\)"$/\1/p' configure.ml)
 APP=bin/CoqIDE_${VERSION}.app
 
@@ -28,4 +28,8 @@ codesign -f -s - $APP
 mkdir -p $DMGDIR
 ln -sf /Applications $DMGDIR/Applications
 cp -r $APP $DMGDIR
+
+# Temporary countermeasure to hdiutil error 5341
+head -c9703424 /dev/urandom > $DMGDIR/.padding
+
 hdiutil create -imagekey zlib-level=9 -volname CoqIDE_$VERSION -srcfolder $DMGDIR -ov -format UDZO CoqIDE_$VERSION.dmg
diff --git a/dev/build/windows/CAVEATS.txt b/dev/build/windows/CAVEATS.txt
new file mode 100644
index 00000000..cb1ae3aa
--- /dev/null
+++ b/dev/build/windows/CAVEATS.txt
@@ -0,0 +1,22 @@
+===== Environemt SIZE =====

+

+find and xargs can fail if the environment is to large. I think the limit is 8k.

+

+xargs --show-limits

+

+shows the actual environment size

+

+The configure_profile.sh script sets ORIGINAL_PATH (set by cygwin) to "" to

+avoid issues

+

+===== OCAMLLIB =====

+

+If the environment variable OCAMLLIB is defined, it takes precedence over the

+internal paths of ocaml tools. This usually messes up things considerably. A

+typical failure is

+

+Error: Error on dynamically loaded library: .\dlllablgtk2.dll: %1 is not a valid Win32 application.

+

+The configure_profile.sh script clears OCAMLLIB, but if you use the ocaml

+compiler from outside the provided cygwin shell, OCAMLLIB might be defined.

+

diff --git a/dev/build/windows/MakeCoq_84pl6_abs_ocaml.bat b/dev/build/windows/MakeCoq_84pl6_abs_ocaml.bat
new file mode 100644
index 00000000..bdcb01db
--- /dev/null
+++ b/dev/build/windows/MakeCoq_84pl6_abs_ocaml.bat
@@ -0,0 +1,10 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=64 ^

+  -mode=absolute ^

+  -ocaml=Y ^

+  -make=Y ^

+  -coqver=8.4pl6 ^

+  -destcyg=%ROOTPATH%\cygwin_coq64_84pl6_abs ^

+  -destcoq=%ROOTPATH%\coq64_84pl6_abs

diff --git a/dev/build/windows/MakeCoq_85pl2_abs_ocaml.bat b/dev/build/windows/MakeCoq_85pl2_abs_ocaml.bat
new file mode 100644
index 00000000..2e4a692e
--- /dev/null
+++ b/dev/build/windows/MakeCoq_85pl2_abs_ocaml.bat
@@ -0,0 +1,10 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=64 ^

+  -mode=absolute ^

+  -ocaml=Y ^

+  -make=Y ^

+  -coqver=8.5pl2 ^

+  -destcyg=%ROOTPATH%\cygwin_coq64_85pl2_abs ^

+  -destcoq=%ROOTPATH%\coq64_85pl2_abs

diff --git a/dev/build/windows/MakeCoq_85pl3_abs_ocaml.bat b/dev/build/windows/MakeCoq_85pl3_abs_ocaml.bat
new file mode 100644
index 00000000..6e4e440a
--- /dev/null
+++ b/dev/build/windows/MakeCoq_85pl3_abs_ocaml.bat
@@ -0,0 +1,10 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=64 ^

+  -mode=absolute ^

+  -ocaml=Y ^

+  -make=Y ^

+  -coqver=8.5pl3 ^

+  -destcyg=%ROOTPATH%\cygwin_coq64_85pl3_abs ^

+  -destcoq=%ROOTPATH%\coq64_85pl3_abs

diff --git a/dev/build/windows/MakeCoq_85pl3_installer.bat b/dev/build/windows/MakeCoq_85pl3_installer.bat
new file mode 100644
index 00000000..c305e2f5
--- /dev/null
+++ b/dev/build/windows/MakeCoq_85pl3_installer.bat
@@ -0,0 +1,8 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=64 ^

+  -installer=Y ^

+  -coqver=8.5pl3 ^

+  -destcyg=%ROOTPATH%\cygwin_coq64_85pl3_inst ^

+  -destcoq=%ROOTPATH%\coq64_85pl3_inst

diff --git a/dev/build/windows/MakeCoq_85pl3_installer_32.bat b/dev/build/windows/MakeCoq_85pl3_installer_32.bat
new file mode 100644
index 00000000..d87ff591
--- /dev/null
+++ b/dev/build/windows/MakeCoq_85pl3_installer_32.bat
@@ -0,0 +1,8 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=32 ^

+  -installer=Y ^

+  -coqver=8.5pl3 ^

+  -destcyg=%ROOTPATH%\cygwin_coq32_85pl3_inst ^

+  -destcoq=%ROOTPATH%\coq32_85pl3_inst

diff --git a/dev/build/windows/MakeCoq_86_abs_ocaml.bat b/dev/build/windows/MakeCoq_86_abs_ocaml.bat
new file mode 100644
index 00000000..50483c4d
--- /dev/null
+++ b/dev/build/windows/MakeCoq_86_abs_ocaml.bat
@@ -0,0 +1,10 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=64 ^

+  -mode=absolute ^

+  -ocaml=Y ^

+  -make=Y ^

+  -coqver=8.6 ^

+  -destcyg=%ROOTPATH%\cygwin_coq64_86_abs ^

+  -destcoq=%ROOTPATH%\coq64_86_abs

diff --git a/dev/build/windows/MakeCoq_86_installer.bat b/dev/build/windows/MakeCoq_86_installer.bat
new file mode 100644
index 00000000..263520ff
--- /dev/null
+++ b/dev/build/windows/MakeCoq_86_installer.bat
@@ -0,0 +1,8 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=64 ^

+  -installer=Y ^

+  -coqver=8.6 ^

+  -destcyg=%ROOTPATH%\cygwin_coq64_86_inst ^

+  -destcoq=%ROOTPATH%\coq64_86_inst

diff --git a/dev/build/windows/MakeCoq_86_installer_32.bat b/dev/build/windows/MakeCoq_86_installer_32.bat
new file mode 100644
index 00000000..14921dd7
--- /dev/null
+++ b/dev/build/windows/MakeCoq_86_installer_32.bat
@@ -0,0 +1,8 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=32 ^

+  -installer=Y ^

+  -coqver=8.6 ^

+  -destcyg=%ROOTPATH%\cygwin_coq32_86_inst ^

+  -destcoq=%ROOTPATH%\coq32_86_inst

diff --git a/dev/build/windows/MakeCoq_86beta1_abs_ocaml.bat b/dev/build/windows/MakeCoq_86beta1_abs_ocaml.bat
new file mode 100644
index 00000000..914c332f
--- /dev/null
+++ b/dev/build/windows/MakeCoq_86beta1_abs_ocaml.bat
@@ -0,0 +1,10 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=64 ^

+  -mode=absolute ^

+  -ocaml=Y ^

+  -make=Y ^

+  -coqver=8.6beta1 ^

+  -destcyg=%ROOTPATH%\cygwin_coq64_86beta1_abs ^

+  -destcoq=%ROOTPATH%\coq64_86beta1_abs

diff --git a/dev/build/windows/MakeCoq_86beta1_installer.bat b/dev/build/windows/MakeCoq_86beta1_installer.bat
new file mode 100644
index 00000000..76a5bb35
--- /dev/null
+++ b/dev/build/windows/MakeCoq_86beta1_installer.bat
@@ -0,0 +1,8 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=64 ^

+  -installer=Y ^

+  -coqver=8.6beta1 ^

+  -destcyg=%ROOTPATH%\cygwin_coq64_86beta1_inst ^

+  -destcoq=%ROOTPATH%\coq64_86beta1_inst

diff --git a/dev/build/windows/MakeCoq_86beta1_installer_32.bat b/dev/build/windows/MakeCoq_86beta1_installer_32.bat
new file mode 100644
index 00000000..f53232b6
--- /dev/null
+++ b/dev/build/windows/MakeCoq_86beta1_installer_32.bat
@@ -0,0 +1,8 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=32 ^

+  -installer=Y ^

+  -coqver=8.6beta1 ^

+  -destcyg=%ROOTPATH%\cygwin_coq32_86beta1_inst ^

+  -destcoq=%ROOTPATH%\coq32_86beta1_inst

diff --git a/dev/build/windows/MakeCoq_86git_abs_ocaml.bat b/dev/build/windows/MakeCoq_86git_abs_ocaml.bat
new file mode 100644
index 00000000..f1d855a0
--- /dev/null
+++ b/dev/build/windows/MakeCoq_86git_abs_ocaml.bat
@@ -0,0 +1,10 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=64 ^

+  -mode=absolute ^

+  -ocaml=Y ^

+  -make=Y ^

+  -coqver=git-v8.6 ^

+  -destcyg=%ROOTPATH%\cygwin_coq64_86git_abs ^

+  -destcoq=%ROOTPATH%\coq64_86git_abs

diff --git a/dev/build/windows/MakeCoq_86git_abs_ocaml_gtksrc.bat b/dev/build/windows/MakeCoq_86git_abs_ocaml_gtksrc.bat
new file mode 100644
index 00000000..70ab42bc
--- /dev/null
+++ b/dev/build/windows/MakeCoq_86git_abs_ocaml_gtksrc.bat
@@ -0,0 +1,11 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=64 ^

+  -mode=absolute ^

+  -ocaml=Y ^

+  -make=Y ^

+  -gtksrc=Y ^

+  -coqver=git-v8.6 ^

+  -destcyg=%ROOTPATH%\cygwin_coq64_86git_abs_gtksrc ^

+  -destcoq=%ROOTPATH%\coq64_86git_abs_gtksrc

diff --git a/dev/build/windows/MakeCoq_86git_installer.bat b/dev/build/windows/MakeCoq_86git_installer.bat
new file mode 100644
index 00000000..40506318
--- /dev/null
+++ b/dev/build/windows/MakeCoq_86git_installer.bat
@@ -0,0 +1,8 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=64 ^

+  -installer=Y ^

+  -coqver=git-v8.6 ^

+  -destcyg=%ROOTPATH%\cygwin_coq64_86git_inst ^

+  -destcoq=%ROOTPATH%\coq64_86git_inst

diff --git a/dev/build/windows/MakeCoq_86git_installer2.bat b/dev/build/windows/MakeCoq_86git_installer2.bat
new file mode 100644
index 00000000..d184f0e3
--- /dev/null
+++ b/dev/build/windows/MakeCoq_86git_installer2.bat
@@ -0,0 +1,8 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=64 ^

+  -installer=Y ^

+  -coqver=git-v8.6 ^

+  -destcyg=%ROOTPATH%\cygwin_coq64_86git_inst2 ^

+  -destcoq=%ROOTPATH%\coq64_86git_inst2

diff --git a/dev/build/windows/MakeCoq_86git_installer_32.bat b/dev/build/windows/MakeCoq_86git_installer_32.bat
new file mode 100644
index 00000000..b9127c94
--- /dev/null
+++ b/dev/build/windows/MakeCoq_86git_installer_32.bat
@@ -0,0 +1,8 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=32 ^

+  -installer=Y ^

+  -coqver=git-v8.6 ^

+  -destcyg=%ROOTPATH%\cygwin_coq32_86git_inst ^

+  -destcoq=%ROOTPATH%\coq32_86git_inst

diff --git a/dev/build/windows/MakeCoq_86rc1_abs_ocaml.bat b/dev/build/windows/MakeCoq_86rc1_abs_ocaml.bat
new file mode 100644
index 00000000..c0669f01
--- /dev/null
+++ b/dev/build/windows/MakeCoq_86rc1_abs_ocaml.bat
@@ -0,0 +1,10 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=64 ^

+  -mode=absolute ^

+  -ocaml=Y ^

+  -make=Y ^

+  -coqver=8.6rc1 ^

+  -destcyg=%ROOTPATH%\cygwin_coq64_86rc1_abs ^

+  -destcoq=%ROOTPATH%\coq64_86rc1_abs

diff --git a/dev/build/windows/MakeCoq_86rc1_installer.bat b/dev/build/windows/MakeCoq_86rc1_installer.bat
new file mode 100644
index 00000000..66234ebb
--- /dev/null
+++ b/dev/build/windows/MakeCoq_86rc1_installer.bat
@@ -0,0 +1,8 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=64 ^

+  -installer=Y ^

+  -coqver=8.6rc1 ^

+  -destcyg=%ROOTPATH%\cygwin_coq64_86rc1_inst ^

+  -destcoq=%ROOTPATH%\coq64_86rc1_inst

diff --git a/dev/build/windows/MakeCoq_86rc1_installer_32.bat b/dev/build/windows/MakeCoq_86rc1_installer_32.bat
new file mode 100644
index 00000000..96f43e16
--- /dev/null
+++ b/dev/build/windows/MakeCoq_86rc1_installer_32.bat
@@ -0,0 +1,8 @@
+call MakeCoq_SetRootPath

+

+call MakeCoq_MinGW.bat ^

+  -arch=32 ^

+  -installer=Y ^

+  -coqver=8.6rc1 ^

+  -destcyg=%ROOTPATH%\cygwin_coq32_86rc1_inst ^

+  -destcoq=%ROOTPATH%\coq32_86rc1_inst

diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat
new file mode 100644
index 00000000..1e08cc5a
--- /dev/null
+++ b/dev/build/windows/MakeCoq_MinGW.bat
@@ -0,0 +1,445 @@
+@ECHO OFF
+
+REM ========== COPYRIGHT/COPYLEFT ==========
+
+REM (C) 2016 Intel Deutschland GmbH
+REM Author: Michael Soegtrop
+
+REM Released to the public by Intel under the
+REM GNU Lesser General Public License Version 2.1 or later
+REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
+
+REM ========== NOTES ==========
+
+REM For Cygwin setup command line options
+REM see https://cygwin.com/faq/faq.html#faq.setup.cli
+
+REM ========== DEFAULT VALUES FOR PARAMETERS ==========
+
+REM For a description of all parameters, see ReadMe.txt
+
+SET BATCHFILE=%0
+SET BATCHDIR=%~dp0
+
+REM see -arch in ReadMe.txt, but values are x86_64 or i686 (not 64 or 32)
+SET ARCH=x86_64
+
+REM see -mode in ReadMe.txt
+SET INSTALLMODE=absolute
+
+REM see -installer in ReadMe.txt
+SET MAKEINSTALLER=N
+
+REM see -ocaml in ReadMe.txt
+SET INSTALLOCAML=N
+
+REM see -make in ReadMe.txt
+SET INSTALLMAKE=Y
+
+REM see -destcyg in ReadMe.txt
+SET DESTCYG=C:\bin\cygwin_coq
+
+REM see -destcoq in ReadMe.txt
+SET DESTCOQ=C:\bin\coq
+
+REM see -setup in ReadMe.txt
+SET SETUP=setup-x86_64.exe
+
+REM see -proxy in ReadMe.txt
+IF DEFINED HTTP_PROXY (
+  SET PROXY="%HTTP_PROXY:http://=%"
+) else (
+  SET PROXY=""
+)
+
+REM see -cygrepo in ReadMe.txt
+SET CYGWIN_REPOSITORY=http://ftp.inf.tu-dresden.de/software/windows/cygwin32
+
+REM see -cygcache in ReadMe.txt
+SET CYGWIN_LOCAL_CACHE_WFMT=%BATCHDIR%cygwin_cache
+
+REM see -cyglocal in ReadMe.txt
+SET CYGWIN_FROM_CACHE=N
+
+REM see -cygquiet in ReadMe.txt
+SET CYGWIN_QUIET=Y
+
+REM see -srccache in ReadMe.txt
+SET SOURCE_LOCAL_CACHE_WFMT=%BATCHDIR%source_cache
+
+REM see -coqver in ReadMe.txt
+SET COQ_VERSION=8.5pl3
+
+REM see -gtksrc in ReadMe.txt
+SET GTK_FROM_SOURCES=N
+
+REM see -threads in ReadMe.txt
+SET MAKE_THREADS=8
+
+REM ========== PARSE COMMAND LINE PARAMETERS ==========
+
+SHIFT
+
+:Parse
+
+IF "%0" == "-arch" (
+  IF "%1" == "32" (
+    SET ARCH=i686
+    SET SETUP=setup-x86.exe
+  ) ELSE (
+    IF "%1" == "64" (
+      SET ARCH=x86_64
+      SET SETUP=setup-x86_64.exe
+    ) ELSE (
+      ECHO "Invalid -arch, valid are 32 and 64"
+      GOTO :EOF
+    )
+  )
+  SHIFT
+  SHIFT
+  GOTO Parse
+)
+
+IF "%0" == "-mode" (
+  IF "%1" == "mingwincygwin" (
+    SET INSTALLMODE=%1
+  ) ELSE (
+    IF "%1" == "absolute" (
+      SET INSTALLMODE=%1
+    ) ELSE (
+      IF "%1" == "relocatable" (
+        SET INSTALLMODE=%1
+      ) ELSE (
+        ECHO "Invalid -mode, valid are mingwincygwin, absolute and relocatable"
+        GOTO :EOF
+      )
+    )
+  )
+  SHIFT
+  SHIFT
+  GOTO Parse
+)
+
+IF "%0" == "-installer" (
+  SET MAKEINSTALLER=%1
+  SHIFT
+  SHIFT
+  GOTO Parse
+)
+
+IF "%0" == "-ocaml" (
+  SET INSTALLOCAML=%1
+  SHIFT
+  SHIFT
+  GOTO Parse
+)
+
+IF "%0" == "-make" (
+  SET INSTALLMAKE=%1
+  SHIFT
+  SHIFT
+  GOTO Parse
+)
+
+IF "%0" == "-destcyg" (
+  SET DESTCYG=%1
+  SHIFT
+  SHIFT
+  GOTO Parse
+)
+
+IF "%0" == "-destcoq" (
+  SET DESTCOQ=%1
+  SHIFT
+  SHIFT
+  GOTO Parse
+)
+
+IF "%0" == "-setup" (
+  SET SETUP=%1
+  SHIFT
+  SHIFT
+  GOTO Parse
+)
+
+IF "%0" == "-proxy" (
+  SET PROXY="%1"
+  SHIFT
+  SHIFT
+  GOTO Parse
+)
+
+IF "%0" == "-cygrepo" (
+  SET CYGWIN_REPOSITORY="%1"
+  SHIFT
+  SHIFT
+  GOTO Parse
+)
+
+IF "%0" == "-cygcache" (
+  SET CYGWIN_LOCAL_CACHE_WFMT="%1"
+  SHIFT
+  SHIFT
+  GOTO Parse
+)
+
+IF "%0" == "-cyglocal" (
+  SET CYGWIN_FROM_CACHE=%1
+  SHIFT
+  SHIFT
+  GOTO Parse
+)
+
+IF "%0" == "-cygquiet" (
+  SET CYGWIN_QUIET=%1
+  SHIFT
+  SHIFT
+  GOTO Parse
+)
+
+IF "%0" == "-srccache" (
+  SET SOURCE_LOCAL_CACHE_WFMT="%1"
+  SHIFT
+  SHIFT
+  GOTO Parse
+)
+
+IF "%0" == "-coqver" (
+  SET COQ_VERSION=%1
+  SHIFT
+  SHIFT
+  GOTO Parse
+)
+
+IF "%0" == "-gtksrc" (
+  SET GTK_FROM_SOURCES=%1
+  SHIFT
+  SHIFT
+  GOTO Parse
+)
+
+IF "%0" == "-threads" (
+  SET MAKE_THREADS=%1
+  SHIFT
+  SHIFT
+  GOTO Parse
+)
+
+IF NOT "%0" == "" (
+  ECHO Install cygwin and download, compile and install OCaml and Coq for MinGW
+  ECHO !!! Illegal parameter %0
+  ECHO Usage: 
+  ECHO MakeCoq_MinGW
+  CALL :PrintPars
+  goto :EOF
+)
+
+IF NOT EXIST %SETUP% (
+  ECHO The cygwin setup program %SETUP% doesn't exist. You must download it from https://cygwin.com/install.html.
+  GOTO :EOF
+)
+
+REM ========== ADJUST PARAMETERS ==========
+
+IF "%INSTALLMODE%" == "mingwincygwin" (
+  SET DESTCOQ=%DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw
+)
+
+IF "%MAKEINSTALLER%" == "Y" (
+  SET INSTALLMODE=relocatable
+  SET INSTALLOCAML=Y
+  SET INSTALLMAKE=Y
+)
+
+REM ========== CONFIRM PARAMETERS ==========
+
+CALL :PrintPars
+REM Note: DOS batch replaces variables on parsing, so one can't use a variable just set in an () block
+IF "%COQREGTESTING%"=="Y" (GOTO :DontAsk)
+  SET /p ANSWER=Is this correct? y/n 
+  IF NOT "%ANSWER%"=="y" (GOTO :EOF)
+:DontAsk
+
+REM ========== DERIVED VARIABLES ==========
+
+SET CYGWIN_INSTALLDIR_WFMT=%DESTCYG%
+SET RESULT_INSTALLDIR_WFMT=%DESTCOQ%
+SET TARGET_ARCH=%ARCH%-w64-mingw32
+SET BASH=%CYGWIN_INSTALLDIR_WFMT%\bin\bash
+
+REM Convert pathes to various formats
+REM WFMT = windows format (C:\..)          Used in this batch file.
+REM CFMT = cygwin format (\cygdrive\c\..)  Used for Cygwin PATH varible, which is : separated, so C: doesn't work.
+REM MFMT = MinGW format (C:/...)           Used for the build, because \\ requires escaping. Mingw can handle \ and /.
+
+SET CYGWIN_INSTALLDIR_MFMT=%CYGWIN_INSTALLDIR_WFMT:\=/%
+SET RESULT_INSTALLDIR_MFMT=%RESULT_INSTALLDIR_WFMT:\=/%
+SET SOURCE_LOCAL_CACHE_MFMT=%SOURCE_LOCAL_CACHE_WFMT:\=/%
+
+SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_MFMT:C:/=/cygdrive/c/%
+SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_MFMT:C:/=/cygdrive/c/%
+SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_MFMT:C:/=/cygdrive/c/%
+
+SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:D:/=/cygdrive/d/%
+SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:D:/=/cygdrive/d/%
+SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:D:/=/cygdrive/d/%
+
+SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:E:/=/cygdrive/e/%
+SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:E:/=/cygdrive/e/%
+SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:E:/=/cygdrive/e/%
+
+ECHO CYGWIN INSTALL DIR (WIN)    = %CYGWIN_INSTALLDIR_WFMT%
+ECHO CYGWIN INSTALL DIR (MINGW)  = %CYGWIN_INSTALLDIR_MFMT%
+ECHO CYGWIN INSTALL DIR (CYGWIN) = %CYGWIN_INSTALLDIR_CFMT%
+ECHO RESULT INSTALL DIR (WIN)    = %RESULT_INSTALLDIR_WFMT%
+ECHO RESULT INSTALL DIR (MINGW)  = %RESULT_INSTALLDIR_MFMT%
+ECHO RESULT INSTALL DIR (CYGWIN) = %RESULT_INSTALLDIR_CFMT%
+
+REM WARNING: Add a space after the = in case you want set this to empty, otherwise the variable will be unset
+SET MAKE_OPT=-j %MAKE_THREADS% 
+
+REM ========== DERIVED CYGWIN SETUP OPTIONS ==========
+
+REM WARNING: Add a space after the = otherwise the variable will be unset
+SET CYGWIN_OPT= 
+
+IF "%CYGWIN_FROM_CACHE%" == "Y" (
+  SET CYGWIN_OPT= %CYGWIN_OPT% -L
+)
+
+IF "%CYGWIN_QUIET%" == "Y" (
+  SET CYGWIN_OPT= %CYGWIN_OPT% -q --no-admin
+)
+
+IF "%GTK_FROM_SOURCES%"=="N" (
+  SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk2.0,mingw64-%ARCH%-gtksourceview2.0
+)
+
+ECHO ========== INSTALL CYGWIN ==========
+
+REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES.
+REM Otherwise chmod won't work and e.g. the ocaml build will fail.
+REM Cygwin setup does not touch the ACLs of existing folders.
+REM => Create the setup log in a temporary location and move it later.
+
+REM Get Unique temporary file name
+:logfileloop
+SET LOGFILE=%TEMP%\CygwinSetUp%RANDOM%-%RANDOM%-%RANDOM%-%RANDOM%.log
+if exist "%LOGFILE%" goto :logfileloop
+
+REM Run Cygwin Setup
+
+SET RUNSETUP=Y
+IF EXIST "%CYGWIN_INSTALLDIR_WFMT%\etc\setup\installed.db" (
+  SET RUNSETUP=N
+)
+IF NOT "%CYGWIN_QUIET%" == "Y" (
+  SET RUNSETUP=Y
+)
+
+IF "%RUNSETUP%"=="Y" (
+  %SETUP% ^
+    --proxy %PROXY% ^
+    --site %CYGWIN_REPOSITORY% ^
+    --root %CYGWIN_INSTALLDIR_WFMT% ^
+    --local-package-dir %CYGWIN_LOCAL_CACHE_WFMT% ^
+    --no-shortcuts ^
+    %CYGWIN_OPT% ^
+    -P wget,curl,git,make,unzip ^
+    -P gcc-core,gcc-g++ ^
+    -P gdb,liblzma5 ^
+    -P patch,automake1.14,automake1.15 ^
+    -P mingw64-%ARCH%-binutils,mingw64-%ARCH%-gcc-core,mingw64-%ARCH%-gcc-g++,mingw64-%ARCH%-pkg-config,mingw64-%ARCH%-windows_default_manifest ^
+    -P mingw64-%ARCH%-headers,mingw64-%ARCH%-runtime,mingw64-%ARCH%-pthreads,mingw64-%ARCH%-zlib ^
+    -P libiconv-devel,libunistring-devel,libncurses-devel ^
+    -P gettext-devel,libgettextpo-devel ^
+    -P libglib2.0-devel,libgdk_pixbuf2.0-devel ^
+    -P libfontconfig1 ^
+    -P gtk-update-icon-cache ^
+    -P libtool,automake ^
+    -P intltool ^
+    > "%LOGFILE%" ^
+    || GOTO :Error
+
+  MKDIR %CYGWIN_INSTALLDIR_WFMT%\build
+  MKDIR %CYGWIN_INSTALLDIR_WFMT%\build\buildlogs
+  MOVE  "%LOGFILE%" %CYGWIN_INSTALLDIR_WFMT%\build\buildlogs\cygwinsetup.log || GOTO :Error
+)
+
+
+IF NOT "%CYGWIN_QUIET%" == "Y" (
+  REM Like most setup programs, cygwin setup starts the real setup as a separate process, so wait for it.
+  REM This is not required with the -cygquiet=Y and the resulting --no-admin option.
+  :waitsetup
+  tasklist /fi "imagename eq %SETUP%" | find ":" > NUL
+  IF ERRORLEVEL 1 GOTO waitsetup
+)
+
+ECHO ========== CONFIGURE CYGWIN USER ACCOUNT ==========
+
+copy %BATCHDIR%\configure_profile.sh %CYGWIN_INSTALLDIR_WFMT%\var\tmp || GOTO :Error
+%BASH% --login %CYGWIN_INSTALLDIR_CFMT%\var\tmp\configure_profile.sh %PROXY% || GOTO :Error
+
+ECHO ========== BUILD COQ ==========
+
+MKDIR %CYGWIN_INSTALLDIR_WFMT%\build
+MKDIR %CYGWIN_INSTALLDIR_WFMT%\build\patches
+
+COPY %BATCHDIR%\makecoq_mingw.sh    %CYGWIN_INSTALLDIR_WFMT%\build || GOTO :Error
+COPY %BATCHDIR%\patches_coq\*.* %CYGWIN_INSTALLDIR_WFMT%\build\patches || GOTO :Error
+
+%BASH% --login %CYGWIN_INSTALLDIR_CFMT%\build\makecoq_mingw.sh || GOTO :Error
+
+ECHO ========== FINISHED ==========
+
+GOTO :EOF
+
+ECHO ========== BATCH FUNCTIONS ==========
+
+:PrintPars
+  REM  01234567890123456789012345678901234567890123456789012345678901234567890123456789
+  ECHO -arch     ^<i686 or x86_64^> Set cygwin, ocaml and coq to 32 or 64 bit
+  ECHO -mode     ^<mingwincygwin = install coq in default cygwin mingw sysroot^>
+  ECHO           ^<absoloute = install coq in -destcoq absulute path^>
+  ECHO           ^<relocatable = install relocatable coq in -destcoq path^>
+  ECHO -installer^<Y or N^> create a windows installer (will be in /build/coq/dev/nsis)
+  ECHO -ocaml    ^<Y or N^> install OCaml in Coq folder (Y) or just in cygwin folder (N)
+  ECHO -make     ^<Y or N^> install GNU Make in Coq folder (Y) or not (N)
+  ECHO -destcyg  ^<path to cygwin destination folder^>
+  ECHO -destcoq  ^<path to coq destination folder (mode=absoloute/relocatable)^>
+  ECHO -setup    ^<cygwin setup program name^> (auto adjusted to -arch)
+  ECHO -proxy    ^<internet proxy^>
+  ECHO -cygrepo  ^<cygwin download repository^>
+  ECHO -cygcache ^<local cygwin repository/cache^>
+  ECHO -cyglocal ^<Y or N^> install cygwin from cache 
+  ECHO -cygquiet ^<Y or N^> install cygwin without user interaction
+  ECHO -srccache ^<local source code repository/cache^>
+  ECHO -coqver   ^<Coq version to install^> 
+  ECHO -gtksrc   ^<Y or N^> build GTK ^(90 min^) or use cygwin version
+  ECHO -threads  ^<1..N^> Number of make threads
+  ECHO(
+  ECHO See ReadMe.txt for a detailed description of all parameters
+  ECHO(
+  ECHO Parameter values (default or currently set):
+  ECHO -arch     = %ARCH%
+  ECHO -mode     = %INSTALLMODE%
+  ECHO -ocaml    = %INSTALLOCAML%
+  ECHO -installer= %MAKEINSTALLER%
+  ECHO -make     = %INSTALLMAKE%
+  ECHO -destcyg  = %DESTCYG% 
+  ECHO -destcoq  = %DESTCOQ% 
+  ECHO -setup    = %SETUP% 
+  ECHO -proxy    = %PROXY%
+  ECHO -cygrepo  = %CYGWIN_REPOSITORY%
+  ECHO -cygcache = %CYGWIN_LOCAL_CACHE_WFMT%
+  ECHO -cyglocal = %CYGWIN_FROM_CACHE%
+  ECHO -cygquiet = %CYGWIN_QUIET%
+  ECHO -srccache = %SOURCE_LOCAL_CACHE_WFMT%
+  ECHO -coqver   = %COQ_VERSION%
+  ECHO -gtksrc   = %GTK_FROM_SOURCES%
+  ECHO -threads  = %MAKE_THREADS%
+  GOTO :EOF
+
+:Error
+ECHO Building Coq failed with error code %errorlevel%
+EXIT /b %errorlevel%
diff --git a/dev/build/windows/MakeCoq_SetRootPath.bat b/dev/build/windows/MakeCoq_SetRootPath.bat
new file mode 100644
index 00000000..3a371172
--- /dev/null
+++ b/dev/build/windows/MakeCoq_SetRootPath.bat
@@ -0,0 +1,16 @@
+@ ECHO OFF
+
+REM Figure out a root path for coq and cygwin
+
+REM For the \nul trick for testing folders see
+REM https://support.microsoft.com/en-us/kb/65994
+
+IF EXIST D:\bin\nul (
+  SET ROOTPATH=D:\bin
+) else if EXIST C:\bin (
+  SET ROOTPATH=C:\bin
+) else (
+  SET ROOTPATH=C:
+)
+
+ECHO ROOTPATH set to %ROOTPATH%
diff --git a/dev/build/windows/MakeCoq_regtest_noproxy.bat b/dev/build/windows/MakeCoq_regtest_noproxy.bat
new file mode 100644
index 00000000..2b0b83fe
--- /dev/null
+++ b/dev/build/windows/MakeCoq_regtest_noproxy.bat
@@ -0,0 +1,18 @@
+call MakeCoq_SetRootPath

+

+SET HTTP_PROXY=

+EXPORT HTTP_PROXY=

+MKDIR C:\Temp\srccache

+

+call MakeCoq_MinGW.bat ^

+  -arch=64 ^

+  -mode=absolute ^

+  -ocaml=Y ^

+  -make=Y ^

+  -coqver 8.5pl2 ^

+  -srccache C:\Temp\srccache ^

+  -cygquiet=Y ^

+  -destcyg   %ROOTPATH%\cygwin_coq64_85pl2_abs ^

+  -destcoq   %ROOTPATH%\coq64_85pl2_abs

+
+pause
\ No newline at end of file
diff --git a/dev/build/windows/MakeCoq_regtests.bat b/dev/build/windows/MakeCoq_regtests.bat
new file mode 100644
index 00000000..6e36d014
--- /dev/null
+++ b/dev/build/windows/MakeCoq_regtests.bat
@@ -0,0 +1,16 @@
+SET COQREGTESTING=Y
+
+REM Bleeding edge
+call MakeCoq_86git_abs_ocaml.bat
+call MakeCoq_86git_installer.bat
+call MakeCoq_86git_installer_32.bat
+call MakeCoq_86git_abs_ocaml_gtksrc.bat
+
+REM Current stable
+call MakeCoq_85pl3_abs_ocaml.bat
+call MakeCoq_85pl3_installer.bat
+call MakeCoq_85pl3_installer_32.bat
+
+REM Old but might still be used
+call MakeCoq_85pl2_abs_ocaml.bat
+call MakeCoq_84pl6_abs_ocaml.bat
diff --git a/dev/build/windows/ReadMe.txt b/dev/build/windows/ReadMe.txt
new file mode 100644
index 00000000..0faf5bc5
--- /dev/null
+++ b/dev/build/windows/ReadMe.txt
@@ -0,0 +1,460 @@
+==================== Purpose / Goal ====================
+
+The main purpose of these scripts is to build Coq for Windows in a reproducible
+and at least by this script documented way without using binary libraries and
+executables from various sources. These scripts use only MinGW libraries
+provided by Cygwin or compile things from sources. For some libraries there are
+options to build them from sources or to use the Cygwin version.
+
+Another goal (which is not yet achieved) is to have a Coq installer for
+Windows, which includes all tools required for native compute and Coq plugin
+development without Cygwin.
+
+Coq requires OCaml for this and OCaml requires binutils, gcc and a posix shell.
+Since the standard Windows OCaml installation requires Cygwin to deliver some of
+these components, you might be able to imagine that this is not so easy.
+
+These scripts can produce the following:
+
+- Coq running on MinGW
+
+- OCaml producing MinGW code and running on MinGW
+
+- GCC producing MinGW code and running on MinGW
+
+- binutils producing MinGW code and running on MinGW
+
+With "running on MinGW" I mean that the tools accept paths like
+"C:\myfolder\myfile.txt" and that they don't link to a Cygwin or msys DLL. The
+MinGW gcc and binutils provided by Cygwin produce MinGW code, but they run only
+on Cygwin.
+
+With "producing MinGW code" I mean that the programs created by the tools accept
+paths like "C:\myfolder\myfile.txt" and that they don't link to a Cygwin or msys
+DLL.
+
+The missing piece is a posix shell running on plain Windows (without msys or
+Cygwin DLL) and not beeing a binary from obscure sources. I am working on it ...
+
+Since compiling gcc and binutils takes a while and it is not of much use without
+a shell, the building of these components is currently disabled. OCaml is built
+anyway, because this MinGW/MinGW OCaml (rather than a Cygwin/MinGW OCaml) is
+used to compile Coq.
+
+Until the shell is there, the Cygwin created by these scripts is required to run
+OCaml tools. When everything is finished, this will no longer be required.
+
+==================== Usage ====================
+
+The Script MakeCoq_MinGW does:
+- download Cygwin (except the Setup.exe or Setup64.exe)
+- install Cygwin
+- either installs MinGW GTK via Cygwin or compiles it fom sources
+- download, compile and install OCaml, CamlP5, Menhir, lablgtk
+- download, compile and install Coq
+- create a Windows installer (NSIS based)
+
+The parameters are described below. Mostly paths and the HTTP proxy need to be
+set.
+
+There are two main usages:
+
+- Compile and install OCaml and Coq in a given folder
+
+  This works reliably, because absolute library paths can be compiled into Coq
+  and OCaml.
+  
+  WARNING: See the "Purpose / Goal" section above for status.
+  
+  See MakeCoq_85pl2_abs_ocaml.bat for parameters.
+
+- Create a Windows installer.
+
+  This works well for Coq but not so well for OCaml.
+
+  WARNING: See the "Purpose / Goal" section above for status.
+  
+  See MakeCoq_85pl2_installer.bat for parameters.
+
+There is also an option to compile OCaml and Coq inside Cygwin, but this is
+currently not recommended. The resulting Coq and OCaml work, but Coq is slow
+because it scans the largish Cygwin share folder. This will be fixed in a future
+version.
+
+Procedure:
+
+- Unzip contents of CoqSetup.zip in a folder
+
+- Adjust parameters in MakeCoq_85pl2_abs_ocaml.bat or in MakeCoq_85pl2_installer.bat.
+
+- Download Cygwin setup from https://Cygwin.com/install.html
+  For 32 bit Coq : setup-x86.exe    (https://Cygwin.com/setup-x86.exe)
+  For 64 bit Coq : setup-x86_64.exe (https://Cygwin.com/setup-x86_64.exe)
+
+- Run MakeCoq_85pl3_abs_ocaml.bat or MakeCoq_85pl3_installer.bat
+
+- Check MakeCoq_regtests.bat to see what combinations of options are tested
+
+==================== MakeCoq_MinGW Parameters ====================
+
+===== -arch =====
+
+Set the target architecture.
+
+Possible values:
+
+32: Install/build Cygwin, ocaml and coq for 32 bit windows
+
+64: Install/build Cygwin, ocaml and coq for 64 bit windows
+
+Default value: 64
+
+
+===== -mode =====
+
+Set the installation mode / target folder structure.
+  
+Possible values:
+
+mingwinCygwin: Install coq in the default Cygwin mingw sysroot folder.
+               This is %DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw.
+               Todo: The coq share folder should be configured to e.g. /share/coq.
+               As is, coqc scans the complete share folder, which slows it down 5x for short files.
+               
+absoloute:     Install coq in the absolute path given with -destcoq.
+               The resulting Coq will not be relocatable.
+               That is the root folder must not be renamed/moved.
+
+relocatable:   Install coq in the absolute path given with -destcoq.
+               The resulting Coq will be relocatable.
+               That is the root folder may be renamed/moved.
+               If OCaml is installed, please note that OCaml cannot be build really relocatable.
+               If the root folder is moved, the environment variable OCAMLLIB must be set to the libocaml sub folder.
+               Also the file <root>\libocaml\ld.conf must be adjusted.
+
+Default value: absolute
+
+
+===== -installer =====
+
+Create a Windows installer (it will be in build/coq-8.xplx/dev/nsis)
+
+Possible values:
+
+Y: Create a windows installer - this forces -mode=relocatable.
+
+N: Don't create a windows installer - use the created Coq installation as is.
+
+Default value: N
+
+
+===== -ocaml =====
+
+Install OCaml for later use with Coq or just for building.
+
+Possible values:
+
+Y: Install OCaml in the same root as Coq (as given with -coqdest)
+   This also copies all .o, .cmo, .a, .cmxa files in the lib folder required for compiling plugins.
+
+N: Install OCaml in the default Cygwin mingw sysroot folder.
+   This is %DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw.
+
+Default value: N
+
+
+===== -make =====
+
+Build and install MinGW GNU make
+
+Possible values:
+
+Y: Install MinGW GNU make in the same root as Coq (as given with -coqdest).
+
+N: Don't build or install MinGW GNU make.
+   For building everything always Cygwin GNU make is used.
+
+Default value: Y
+
+
+===== -destcyg =====
+
+Destination folder in which Cygwin is installed.
+
+This must be an absolute path in Windows format (with drive letter and \\).
+
+>>>>> This folder may be deleted after the Coq build is finished! <<<<<
+
+Default value: C:\bin\Cygwin_coq
+
+
+===== -destcoq =====
+
+Destination folder in which Coq is installed.
+
+This must be an absolute path in Windows format (with drive letter and \\).
+
+This option is not required if -mode mingwinCygwin is used.
+
+Default value: C:\bin\coq
+
+
+===== -setup =====
+
+Name/path of the Cygwin setup program.
+
+The Cygwin setup program is called setup-x86.exe or setup-x86_64.exe.
+It can be downloaded from: https://Cygwin.com/install.html.
+
+Default value: setup-x86.exe or setup-x86_64.exe, depending on -arch.
+
+
+===== -proxy =====
+
+Internet proxy setting for downloading Cygwin, ocaml and coq.
+
+The format is <server>:<port>, e.g. proxy.mycompany.com:911
+
+The same proxy is used for HTTP, HTTPS and FTP.
+If you need separate proxies for separate protocols, you please put your proxies directly into configure_profile.sh (line 11..13).
+
+Default value: Value of HTTP_PROXY environment variable or none if this variable does not exist.
+
+ATTENTION: With the --proxy setting of the Cygwin setup, it is possible to
+supply a proxy server, but if this parameter is "", Cygwin setup might use proxy
+settings from previous setups. If you once did a Cygwin setup behind a firewall
+and now want to do a Cygwin setup without a firewall, use the -cygquiet=N
+setting to perform a GUI install, where you can adjust the proxy setting.
+
+===== -cygrepo =====
+
+The online repository, from which Cygwin packages are downloaded.
+
+Note: although most repositories end with Cygwin32, they are good for 32 and 64 bit Cygwin.
+
+Default value: http://ftp.inf.tu-dresden.de/software/windows/Cygwin32
+
+>>>>> If you are not in Europe, you might want to change this! <<<<<
+
+
+===== -cygcache =====
+
+The local cache folder for Cygwin repositories.
+
+You can also copy files here from a backup/reference and set -cyglocal.
+The setup will then not download/update from the internet but only use the local cache.
+
+Default value: <folder of MakeCoq_MinGW.bat>\Cygwin_cache
+
+
+===== -cyglocal =====
+
+Control if the Cygwin setup uses the latest version from the internet or the version as is in the local folder.
+
+Possible values:
+
+Y: Install exactly the Cygwin version from the local repository cache.
+   Don't update from the internet.
+
+N: Download the latest Cygwin version from the internet.
+   Update the local repository cache with the latest version.
+
+Default value: N
+
+
+===== -cygquiet =====
+
+Control if the Cygwin setup runs quitely or interactive.
+
+Possible values:
+
+Y: Install Cygwin quitely without user interaction.
+
+N: Install Cygwin interactively (allows to select additional packages).
+
+Default value: Y
+
+
+===== -srccache =====
+
+The local cache folder for ocaml/coq/... sources.
+
+Default value: <folder of MakeCoq_MinGW.bat>\source_cache
+
+
+===== -coqver =====
+
+The version of Coq to download and compile.
+
+Possible values: 8.4pl6, 8.5pl2, 8.5pl3, git-v8.6 
+                 Others might work, but are untested.
+                 8.4 is only tested in mode=absoloute
+
+Default value: 8.5pl3
+
+If git- is prepended, the Coq sources are loaded from git.
+
+ATTENTION: with default options, the scripts cache source tar balls in two
+places, the <destination>/build/tarballs folder and the <scripts>/source_cache
+folder. If you modified something in git, you need to delete the cached tar ball
+in both places!
+
+===== -gtksrc =====
+
+Control if GTK and its prerequisites are build from sources or if binary MinGW packages from Cygwin are used
+
+Possible values:
+
+Y: Build GTK from sources, takes about 90 minutes extra.
+   This is useful, if you want to debug/fix GTK or library issues.
+
+N: Use prebuilt MinGW libraries from Cygwin
+
+
+===== -threads =====
+
+Control the maximum number of make threads for modules which support parallel make.
+
+Possible values: 1..N. 
+                 Should not be more than 1.5x the number of cores.
+                 Should not be more than available RAM/2GB (e.g. 4 for 8GB)
+
+
+==================== TODO ====================
+
+- Installer doesn't remove OCAMLLIB environment variables (it is in the script, but doesn't seem to work)
+- CoqIDE doesn't find theme files
+- Finish / test mingw_in_Cygwin mode (coqide doesn't start, coqc slow cause of scanning complete share folder)
+- Possibly create/login as specific user to bash (not sure if it makes sense - nead to create additional bash login link then)
+- maybe move share/doc/menhir somehwere else (reduces coqc startup time)
+- Use original installed file list for removing files in uninstaller 
+
+==================== Issues with relocation ====================
+
+Coq and OCaml are built in a specific folder and are not really intended for relocation e.g. by an installer.
+Some absolute paths in config files are patched in coq_new.nsi.
+
+Coq is made fairly relocatable by first configuring it with PREFIX=./ and then PREFIX=<installdir>.
+OCaml is made relocatable mostly by defining the OCAMLLIB environment variable and by patching some files.
+If you have issues with one of the remaining (unpatched) files below, please let me know.
+
+Text files patched by the installer:
+
+./ocamllib/ld.conf
+./etc/findlib.conf:destdir="D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib"
+./etc/findlib.conf:path="D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib"
+
+Text files containing the install folder path after install:
+
+./bin/mkcamlp5:LIB=D:/bin/coq64_buildtest_reloc_ocaml20/libocaml/camlp5
+./bin/mkcamlp5.opt:LIB=D:/bin/coq64_buildtest_reloc_ocaml20/libocaml/camlp5
+./libocaml/Makefile.config:PREFIX=D:/bin/coq64_buildtest_reloc_ocaml20
+./libocaml/Makefile.config:LIBDIR=D:/bin/coq64_buildtest_reloc_ocaml20/libocaml
+./libocaml/site-lib/findlib/Makefile.config:OCAML_CORE_BIN=/cygdrive/d/bin/coq64_buildtest_reloc_ocaml20/bin
+./libocaml/site-lib/findlib/Makefile.config:OCAML_SITELIB=D:/bin/coq64_buildtest_reloc_ocaml20\libocaml\site-lib
+./libocaml/site-lib/findlib/Makefile.config:OCAMLFIND_BIN=D:/bin/coq64_buildtest_reloc_ocaml20\bin
+./libocaml/site-lib/findlib/Makefile.config:OCAMLFIND_CONF=D:/bin/coq64_buildtest_reloc_ocaml20\etc\findlib.conf
+./libocaml/topfind:#directory "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib";;
+./libocaml/topfind:  Topdirs.dir_load Format.err_formatter "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib.cma";
+./libocaml/topfind:  Topdirs.dir_load Format.err_formatter "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib_top.cma";
+./libocaml/topfind:(* #load "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib.cma";; *)
+./libocaml/topfind:(* #load "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib_top.cma";; *)
+./man/man1/camlp5.1:These files are installed in the directory D:/bin/coq64_buildtest_reloc_ocaml20/libocaml/camlp5.
+./man/man1/camlp5.1:D:/bin/coq64_buildtest_reloc_ocaml20/libocaml/camlp5
+
+Binary files containing the build folder path after install:
+
+$ find . -type f -exec grep "Cygwin_coq64_buildtest_reloc_ocaml20" {} /dev/null \;
+Binary file ./bin/coqtop.byte.exe matches
+Binary file ./bin/coqtop.exe matches
+Binary file ./bin/ocamldoc.exe matches
+Binary file ./bin/ocamldoc.opt.exe matches
+Binary file ./libocaml/ocamldoc/odoc_info.a matches
+Binary file ./libocaml/ocamldoc/odoc_info.cma matches
+
+Binary files containing the install folder path after install:
+
+$ find . -type f -exec grep "coq64_buildtest_reloc_ocaml20" {} /dev/null \;
+Binary file ./bin/camlp4.exe matches
+Binary file ./bin/camlp4boot.exe matches
+Binary file ./bin/camlp4o.exe matches
+Binary file ./bin/camlp4o.opt.exe matches
+Binary file ./bin/camlp4of.exe matches
+Binary file ./bin/camlp4of.opt.exe matches
+Binary file ./bin/camlp4oof.exe matches
+Binary file ./bin/camlp4oof.opt.exe matches
+Binary file ./bin/camlp4orf.exe matches
+Binary file ./bin/camlp4orf.opt.exe matches
+Binary file ./bin/camlp4r.exe matches
+Binary file ./bin/camlp4r.opt.exe matches
+Binary file ./bin/camlp4rf.exe matches
+Binary file ./bin/camlp4rf.opt.exe matches
+Binary file ./bin/camlp5.exe matches
+Binary file ./bin/camlp5o.exe matches
+Binary file ./bin/camlp5o.opt matches
+Binary file ./bin/camlp5r.exe matches
+Binary file ./bin/camlp5r.opt matches
+Binary file ./bin/camlp5sch.exe matches
+Binary file ./bin/coqc.exe matches
+Binary file ./bin/coqchk.exe matches
+Binary file ./bin/coqdep.exe matches
+Binary file ./bin/coqdoc.exe matches
+Binary file ./bin/coqide.exe matches
+Binary file ./bin/coqmktop.exe matches
+Binary file ./bin/coqtop.byte.exe matches
+Binary file ./bin/coqtop.exe matches
+Binary file ./bin/coqworkmgr.exe matches
+Binary file ./bin/coq_makefile.exe matches
+Binary file ./bin/menhir matches
+Binary file ./bin/mkcamlp4.exe matches
+Binary file ./bin/ocaml.exe matches
+Binary file ./bin/ocamlbuild.byte.exe matches
+Binary file ./bin/ocamlbuild.exe matches
+Binary file ./bin/ocamlbuild.native.exe matches
+Binary file ./bin/ocamlc.exe matches
+Binary file ./bin/ocamlc.opt.exe matches
+Binary file ./bin/ocamldebug.exe matches
+Binary file ./bin/ocamldep.exe matches
+Binary file ./bin/ocamldep.opt.exe matches
+Binary file ./bin/ocamldoc.exe matches
+Binary file ./bin/ocamldoc.opt.exe matches
+Binary file ./bin/ocamlfind.exe matches
+Binary file ./bin/ocamlmklib.exe matches
+Binary file ./bin/ocamlmktop.exe matches
+Binary file ./bin/ocamlobjinfo.exe matches
+Binary file ./bin/ocamlopt.exe matches
+Binary file ./bin/ocamlopt.opt.exe matches
+Binary file ./bin/ocamlprof.exe matches
+Binary file ./bin/ocamlrun.exe matches
+Binary file ./bin/ocpp5.exe matches
+Binary file ./lib/config/coq_config.cmo matches
+Binary file ./lib/config/coq_config.o matches
+Binary file ./lib/grammar/grammar.cma matches
+Binary file ./lib/ide/ide_win32_stubs.o matches
+Binary file ./lib/lib/clib.a matches
+Binary file ./lib/lib/clib.cma matches
+Binary file ./lib/libcoqrun.a matches
+Binary file ./libocaml/camlp4/camlp4fulllib.a matches
+Binary file ./libocaml/camlp4/camlp4fulllib.cma matches
+Binary file ./libocaml/camlp4/camlp4lib.a matches
+Binary file ./libocaml/camlp4/camlp4lib.cma matches
+Binary file ./libocaml/camlp4/camlp4o.cma matches
+Binary file ./libocaml/camlp4/camlp4of.cma matches
+Binary file ./libocaml/camlp4/camlp4oof.cma matches
+Binary file ./libocaml/camlp4/camlp4orf.cma matches
+Binary file ./libocaml/camlp4/camlp4r.cma matches
+Binary file ./libocaml/camlp4/camlp4rf.cma matches
+Binary file ./libocaml/camlp5/odyl.cma matches
+Binary file ./libocaml/compiler-libs/ocamlcommon.a matches
+Binary file ./libocaml/compiler-libs/ocamlcommon.cma matches
+Binary file ./libocaml/dynlink.cma matches
+Binary file ./libocaml/expunge.exe matches
+Binary file ./libocaml/extract_crc.exe matches
+Binary file ./libocaml/libcamlrun.a matches
+Binary file ./libocaml/ocamlbuild/ocamlbuildlib.a matches
+Binary file ./libocaml/ocamlbuild/ocamlbuildlib.cma matches
+Binary file ./libocaml/ocamldoc/odoc_info.a matches
+Binary file ./libocaml/ocamldoc/odoc_info.cma matches
+Binary file ./libocaml/site-lib/findlib/findlib.a matches
+Binary file ./libocaml/site-lib/findlib/findlib.cma matches
+Binary file ./libocaml/site-lib/findlib/findlib.cmxs matches
diff --git a/dev/build/windows/configure_profile.sh b/dev/build/windows/configure_profile.sh
new file mode 100644
index 00000000..09a9cf35
--- /dev/null
+++ b/dev/build/windows/configure_profile.sh
@@ -0,0 +1,32 @@
+#!/bin/bash
+
+rcfile=~/.bash_profile
+donefile=~/.bash_profile.upated
+
+if [ ! -f $donefile ] ; then
+
+    echo >> $rcfile
+    
+    if [ -n "$1" ]; then
+      echo export http_proxy="http://$1" >> $rcfile
+      echo export https_proxy="http://$1" >> $rcfile
+      echo export ftp_proxy="http://$1" >> $rcfile
+    fi
+    
+    mkdir -p $RESULT_INSTALLDIR_CFMT/bin
+
+    # A tightly controlled path helps to avoid issues
+    # Note: the order is important: first have the cygwin binaries, then the mingw binaries in the path!
+    # Note: /bin is mounted at /usr/bin and /lib at /usr/lib and it is common to use /usr/bin in PATH
+    # See cat /proc/mounts
+    echo "export PATH=/usr/local/bin:/usr/bin:$RESULT_INSTALLDIR_CFMT/bin:/usr/$TARGET_ARCH/sys-root/mingw/bin:/cygdrive/c/Windows/system32:/cygdrive/c/Windows" >> $rcfile
+
+    # find and xargs complain if the environment is larger than (I think) 8k.
+    # ORIGINAL_PATH (set by cygwin) can be a few k and exceed the limit
+    echo unset ORIGINAL_PATH >> $rcfile
+    
+    # Other installations of OCaml will mess up things
+    echo unset OCAMLLIB >> $rcfile
+
+    touch $donefile
+fi
\ No newline at end of file
diff --git a/dev/build/windows/difftar-folder.sh b/dev/build/windows/difftar-folder.sh
new file mode 100644
index 00000000..65278d5c
--- /dev/null
+++ b/dev/build/windows/difftar-folder.sh
@@ -0,0 +1,86 @@
+#!/bin/bash
+
+###################### COPYRIGHT/COPYLEFT ######################
+
+# (C) 2016 Intel Deutschland GmbH
+# Author: Michael Soegtrop
+#
+# Released to the public by Intel under the
+# GNU Lesser General Public License Version 2.1 or later
+# See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
+#
+# With very valuable help on building GTK from
+#   https://wiki.gnome.org/Projects/GTK+/Win32/MSVCCompilationOfGTKStack
+#   http://www.gaia-gis.it/spatialite-3.0.0-BETA/mingw64_how_to.html
+
+###################### Script safety and debugging settings ######################
+
+set -o nounset
+
+# Print usage
+
+if [ "$#" -lt 1 ] ; then
+  echo 'Diff a tar (or compressed tar) file with a folder'
+  echo 'difftar-folder.sh <tarfile> [<folder>] [strip]'
+  echo default for folder is .
+  echo default for strip is 0.
+  echo 'strip must be 0 or 1.'
+  exit 1
+fi
+
+# Parse parameters
+
+tarfile=$1
+
+if [ "$#" -ge 2 ] ; then
+  folder=$2
+else
+  folder=.
+fi
+
+if [ "$#" -ge 3 ] ; then
+  strip=$3
+else
+  strip=0
+fi
+
+# Get path prefix if --strip is used
+
+if [ "$strip" -gt 0 ] ; then
+  prefix=`tar -t -f $tarfile | head -1`
+else
+  prefix=
+fi
+
+# Original folder
+
+if [ "$strip" -gt 0 ] ; then
+  orig=${prefix%/}.orig
+elif [ "$folder" = "." ] ; then
+  orig=${tarfile##*/}
+  orig=./${orig%%.tar*}.orig
+elif [ "$folder" = "" ] ; then
+  orig=${tarfile##*/}
+  orig=${orig%%.tar*}.orig
+else
+  orig=$folder.orig
+fi
+echo $orig
+mkdir -p "$orig"
+
+
+# Make sure tar uses english output (for Mod time differs)
+export LC_ALL=C
+
+# Search all files with a deviating modification time using tar --diff
+tar --diff -a -f "$tarfile" --strip $strip --directory "$folder" | grep "Mod time differs" | while read -r file ; do
+  # Substitute ': Mod time differs' with nothing
+  file=${file/: Mod time differs/}
+  # Check if file exists
+  if [ -f "$folder/$file" ] ; then 
+    # Extract original file
+    tar -x -a -f "$tarfile" --strip $strip --directory "$orig" "$prefix$file"
+    # Compute diff
+    diff -u "$orig/$file" "$folder/$file" 
+  fi
+done
\ No newline at end of file
diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh
new file mode 100644
index 00000000..52b15887
--- /dev/null
+++ b/dev/build/windows/makecoq_mingw.sh
@@ -0,0 +1,1270 @@
+#!/bin/bash
+
+###################### COPYRIGHT/COPYLEFT ######################
+
+# (C) 2016 Intel Deutschland GmbH
+# Author: Michael Soegtrop
+#
+# Released to the public by Intel under the
+# GNU Lesser General Public License Version 2.1 or later
+# See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
+#
+# With very valuable help on building GTK from
+#   https://wiki.gnome.org/Projects/GTK+/Win32/MSVCCompilationOfGTKStack
+#   http://www.gaia-gis.it/spatialite-3.0.0-BETA/mingw64_how_to.html
+
+###################### Script safety and debugging settings ######################
+
+set -o nounset
+set -o errexit
+set -x
+
+# Set this to 1 if all module directories shall be removed before build (no incremental make)
+RMDIR_BEFORE_BUILD=1
+
+###################### NOTES #####################
+
+# - This file goes together with MakeCoq_ForMignGW.bat, which sets up cygwin
+#   with all required packages and then calls this script.
+#
+# - This script uses set -o errexit, so if anything fails, the script will stop
+#
+# - cygwin provided mingw64 packages like mingw64-x86_64-zlib are installed to
+#   /usr/$TARGET_ARCH/sys-root/mingw, so we use this as install prefix
+#
+# - if mingw64-x86_64-pkg-config is installed BEFORE building libpng or pixman,
+#   the .pc files are properly created in /usr/$TARGET_ARCH/sys-root/mingw/lib/pkgconfig
+#
+# - pango and some others uses pkg-config executable names without path, which doesn't work in cross compile mode
+#   There are several possible solutions
+#     1.) patch build files to get the prefix from pkg-config and use $prefix/bin/ as path
+#         - doesn't work for pango because automake goes wild
+#         - mingw tools are not able to handle cygwin path (they need absolute windows paths)
+#     2.) export PATH=$PATH:/usr/$TARGET_ARCH/sys-root/mingw/bin
+#         - a bit dangerous because this exposes much more than required
+#         - mingw tools are not able to handle cygwin path (they need absolute windows paths)
+#     3.) Install required tools via cygwin modules libglib2.0-devel and libgdk_pixbuf2.0-devel
+#         - Possibly version compatibility issues
+#         - Possibly mingw/cygwin compatibility issues, e.g. when building font or terminfo databases
+#     4.) Build required tools for mingw and cygwin
+#         - Possibly mingw/cygwin compatibility issues, e.g. when building font or terminfo databases
+#
+#   We use method 3 below
+#   Method 2 can be tried by putting the cross tools in the path before the cygwin tools (in configure_profile.sh)
+#
+# - It is tricky to build 64 bit binaries with 32 bit cross tools and vice versa.
+#   This is because the linker needs to load DLLs from C:\windows\system32, which contains
+#   both 32 bit and 64 bit DLLs, and which one you get depends by some black magic on if the using
+#   app is a 32 bit or 64 bit app. So better build 32 bit mingw with 32 bit cygwin and 64 with 64.
+#   Alternatively the required 32 bit or 64 bit DLLs need to be copied with a 32 bit/64bit cp to some
+#   folder without such black magic.
+#
+# - The file selection for the Coq Windows Installer is done with make install (unlike the original script)
+#   Relocatble builds are first configured with prefix=./ then build and then
+#   reconfigured with prefix=<installroot> before make install.
+
+
+###################### ARCHITECTURES #####################
+
+# The OS on which the build of the tool/lib runs
+BUILD=`gcc -dumpmachine`
+
+# The OS on which the tool runs
+# "`find /bin -name "*mingw32-gcc.exe"`" -dumpmachine
+HOST=$TARGET_ARCH
+
+# The OS for which the tool creates code/for which the libs are
+TARGET=$TARGET_ARCH
+
+# Cygwin uses different arch name for 32 bit than mingw/gcc
+case $ARCH in
+  x86_64) CYGWINARCH=x86_64 ;;
+  i686)   CYGWINARCH=x86 ;;
+  *)      false ;;
+esac
+
+###################### PATHS #####################
+
+# Name and create some 'global' folders
+PATCHES=/build/patches
+BUILDLOGS=/build/buildlogs
+FLAGFILES=/build/flagfiles
+TARBALLS=/build/tarballs
+FILELISTS=/build/filelists
+
+mkdir -p $BUILDLOGS
+mkdir -p $FLAGFILES
+mkdir -p $TARBALLS
+mkdir -p $FILELISTS
+cd /build
+
+
+# sysroot prefix for the above /build/host/target combination
+PREFIX=$CYGWIN_INSTALLDIR_MFMT/usr/$TARGET_ARCH/sys-root/mingw
+
+# Install / Prefix folder for COQ
+PREFIXCOQ=$RESULT_INSTALLDIR_MFMT
+
+# Install / Prefix folder for OCaml
+if [ "$INSTALLOCAML" == "Y" ]; then
+  PREFIXOCAML=$PREFIXCOQ
+else
+  PREFIXOCAML=$PREFIX
+fi
+
+mkdir -p $PREFIX/bin
+mkdir -p $PREFIXCOQ/bin
+mkdir -p $PREFIXOCAML/bin
+
+###################### Copy Cygwin Setup Info #####################
+
+# Copy Cygwin repo ini file and installed files db to tarballs folder.
+# Both files together document the exact selection and version of cygwin packages.
+# Do this as early as possible to avoid changes by other setups (the repo folder is shared).
+
+# Escape URL to folder name
+CYGWIN_REPO_FOLDER=${CYGWIN_REPOSITORY}/
+CYGWIN_REPO_FOLDER=${CYGWIN_REPO_FOLDER//:/%3a}
+CYGWIN_REPO_FOLDER=${CYGWIN_REPO_FOLDER//\//%2f}
+
+# Copy files
+cp $CYGWIN_LOCAL_CACHE_WFMT/$CYGWIN_REPO_FOLDER/$CYGWINARCH/setup.ini $TARBALLS
+cp /etc/setup/installed.db $TARBALLS
+  
+###################### LOGGING #####################
+
+# The folder which receives log files
+mkdir -p buildlogs
+LOGS=`pwd`/buildlogs
+
+# The current log target (first part of the log file name)
+LOGTARGET=other
+
+log1() {
+  "$@" > $LOGS/$LOGTARGET-$1.log 2> $LOGS/$LOGTARGET-$1.err
+}
+
+log2() {
+  "$@" > $LOGS/$LOGTARGET-$1-$2.log 2> $LOGS/$LOGTARGET-$1-$2.err
+}
+
+log_1_3() {
+  "$@" > $LOGS/$LOGTARGET-$1-$3.log 2> $LOGS/$LOGTARGET-$1-$3.err
+}
+
+logn() {
+  LOGTARGETEX=$1
+  shift
+  "$@" > $LOGS/$LOGTARGET-$LOGTARGETEX.log 2> $LOGS/$LOGTARGET-$LOGTARGETEX.err
+}
+ 
+###################### UTILITY FUNCTIONS #####################
+
+# ------------------------------------------------------------------------------
+# Get a source tar ball, expand and patch it
+# - get source archive from $SOURCE_LOCAL_CACHE_CFMT or online using wget
+# - create build folder
+# - extract source archive
+# - patch source file if patch exists
+# 
+# Parameters
+# $1 file server name including protocol prefix
+# $2 file name (without extension)
+# $3 file extension
+# $4 number of path levels to strip from tar (usually 1)
+# $5 module name (if different from archive)
+# $6 expand folder name (if different from module name)
+# ------------------------------------------------------------------------------
+
+function get_expand_source_tar {
+  # Handle optional parameters
+  if [ "$#" -ge 4 ] ; then
+    strip=$4
+  else
+    strip=1
+  fi
+
+  if [ "$#" -ge 5 ] ; then
+    name=$5
+  else
+    name=$2
+  fi
+  
+  if [ "$#" -ge 6 ] ; then
+    folder=$6
+  else
+    folder=$name
+  fi
+  
+  # Set logging target
+  logtargetold=$LOGTARGET
+  LOGTARGET=$name
+  
+  # Get the source archive either from the source cache or online
+  if [ ! -f $TARBALLS/$name.$3 ] ; then
+    if [ -f $SOURCE_LOCAL_CACHE_CFMT/$name.$3 ] ; then
+      cp $SOURCE_LOCAL_CACHE_CFMT/$name.$3 $TARBALLS
+    else
+      wget $1/$2.$3
+      if [ ! "$2.$3" == "$name.$3" ] ; then
+        mv $2.$3 $name.$3
+      fi
+      mv $name.$3 $TARBALLS
+      # Save the source archive in the source cache
+      if [ -d $SOURCE_LOCAL_CACHE_CFMT ] ; then
+        cp $TARBALLS/$name.$3 $SOURCE_LOCAL_CACHE_CFMT
+      fi
+    fi
+  fi
+  
+  # Remove build directory (clean build)
+  if [ $RMDIR_BEFORE_BUILD -eq 1 ] ; then
+    rm -f -r $folder
+  fi
+  
+  # Create build directory and cd
+  mkdir -p $folder
+  cd $folder
+  
+  # Extract source archive
+  if [ "$3" == "zip" ] ; then
+    log1 unzip $TARBALLS/$name.$3
+    if [ "$strip" == "1" ] ; then
+      # Ok, this is dirty, but it works and it fails if there are name clashes
+      mv */* .
+    else
+      echo "Unzip strip count not supported"
+      return 1
+    fi
+  else
+    logn untar tar xvaf $TARBALLS/$name.$3 --strip $strip
+  fi
+  
+  # Patch if patch file exists
+  if [ -f $PATCHES/$name.patch ] ; then
+    log1 patch -p1 -i $PATCHES/$name.patch
+  fi
+  
+  # Go back to base folder
+  cd ..
+
+  LOGTARGET=$logtargetold
+}
+
+# ------------------------------------------------------------------------------
+# Prepare a module build
+# - check if build is already done (name.finished file exists) - if so return 1
+# - create name.started
+# - get source archive from $SOURCE_LOCAL_CACHE_CFMT or online using wget
+# - create build folder
+# - cd to build folder and extract source archive
+# - create bin_special subfolder and add it to $PATH
+# - remember things for build_post
+# 
+# Parameters
+# $1 file server name including protocol prefix
+# $2 file name (without extension)
+# $3 file extension
+# $4 [optional] number of path levels to strip from tar (usually 1)
+# $5 [optional] module name (if different from archive)
+# ------------------------------------------------------------------------------
+
+function build_prep {
+  # Handle optional parameters
+  if [ "$#" -ge 4 ] ; then
+    strip=$4
+  else
+    strip=1
+  fi
+
+  if [ "$#" -ge 5 ] ; then
+    name=$5
+  else
+    name=$2
+  fi
+  
+  # Check if build is already done
+  if [ ! -f flagfiles/$name.finished ] ; then
+    BUILD_PACKAGE_NAME=$name
+    BUILD_OLDPATH=$PATH
+    BUILD_OLDPWD=`pwd`
+    LOGTARGET=$name
+
+    touch flagfiles/$name.started
+    
+    get_expand_source_tar $1 $2 $3 $strip $name
+    
+    cd $name
+    
+    # Create a folder and add it to path, where we can put special binaries
+    # The path is restored in build_post
+    mkdir bin_special
+    PATH=`pwd`/bin_special:$PATH
+    
+    return 0
+  else  
+    return 1
+  fi
+}
+
+# ------------------------------------------------------------------------------
+# Finalize a module build
+# - create name.finished
+# - go back to base folder
+# ------------------------------------------------------------------------------
+
+function build_post {
+  if [ ! -f flagfiles/$BUILD_PACKAGE_NAME.finished ]; then
+    cd $BUILD_OLDPWD
+    touch flagfiles/$BUILD_PACKAGE_NAME.finished
+    PATH=$BUILD_OLDPATH
+    LOGTARGET=other
+  fi
+}
+
+# ------------------------------------------------------------------------------
+# Build and install a module using the standard configure/make/make install process
+# - prepare build (as above)
+# - configure
+# - make
+# - make install
+# - finalize build (as above)
+#
+# parameters
+# $1 file server name including protocol prefix
+# $2 file name (without extension)
+# $3 file extension
+# $4 patch function to call between untar and configure (or true if none)
+# $5.. extra configure arguments
+# ------------------------------------------------------------------------------
+
+function build_conf_make_inst {
+  if build_prep $1 $2 $3 ; then
+    $4
+    logn configure ./configure --build=$BUILD --host=$HOST --target=$TARGET --prefix=$PREFIX "${@:5}"
+    log1 make $MAKE_OPT
+    log2 make install
+    log2 make clean
+    build_post
+  fi
+}
+
+# ------------------------------------------------------------------------------
+# Install all files given by a glob pattern to a given folder
+#
+# parameters
+# $1 glob pattern (in '')
+# $2 target folder
+# ------------------------------------------------------------------------------
+
+function install_glob {
+  # Check if any files matching the pattern exist
+  if [ "$(echo $1)" != "$1" ] ; then
+    install -D -t $2 $1
+  fi
+}
+
+
+# ------------------------------------------------------------------------------
+# Recursively Install all files given by a glob pattern to a given folder
+#
+# parameters
+# $1 source path
+# $2 pattern (in '')
+# $3 target folder
+# ------------------------------------------------------------------------------
+
+function install_rec {
+  ( cd $1 && find -type f -name "$2" -exec install -D -T  $1/{} $3/{} \; )
+}
+
+# ------------------------------------------------------------------------------
+# Write a file list of the target folder
+# The file lists are used to create file lists for the windows installer
+#
+# parameters
+# $1 name of file list
+# ------------------------------------------------------------------------------
+
+function list_files {
+  if [ ! -e "/build/filelists/$1" ] ; then
+    ( cd $PREFIXCOQ && find -type f | sort > /build/filelists/$1 )
+  fi
+}
+
+# ------------------------------------------------------------------------------
+# Compute the set difference of two file lists
+#
+# parameters
+# $1 name of list A-B (set difference of set A minus set B)
+# $2 name of list A
+# $3 name of list B
+# ------------------------------------------------------------------------------
+
+function diff_files {
+  # See http://www.catonmat.net/blog/set-operations-in-unix-shell/ for file list set operations
+  comm -23 <(sort "/build/filelists/$2") <(sort "/build/filelists/$3") > "/build/filelists/$1"
+}
+
+# ------------------------------------------------------------------------------
+# Filter a list of files with a regular expression
+#
+# parameters
+# $1 name of output file list
+# $2 name of input file list
+# $3 name of filter regexp
+# ------------------------------------------------------------------------------
+
+function filter_files {
+  egrep "$3" "/build/filelists/$2" > "/build/filelists/$1"
+}
+
+# ------------------------------------------------------------------------------
+# Convert a file list to NSIS installer format
+#
+# parameters
+# $1 name of file list file (output file is the same with extension .nsi)
+# ------------------------------------------------------------------------------
+
+function files_to_nsis {
+  # Split the path in the file list into path and filename and create SetOutPath and File instructions
+  # Note: File /oname cannot be used, because it does not create the paths as SetOutPath does
+  # Note: I didn't check if the redundant SetOutPath instructions have a bad impact on installer size or install time
+  cat "/build/filelists/$1" | tr '/' '\\' | sed -r 's/^\.(.*)\\([^\\]+)$/SetOutPath $INSTDIR\\\1\nFile ${COQ_SRC_PATH}\\\1\\\2/' > "/build/filelists/$1.nsh"
+}
+
+
+###################### MODULE BUILD FUNCTIONS #####################
+
+##### LIBPNG #####
+
+function make_libpng {
+  build_conf_make_inst  http://prdownloads.sourceforge.net/libpng  libpng-1.6.18  tar.gz  true
+}
+
+##### PIXMAN #####
+
+function make_pixman {
+  build_conf_make_inst  http://cairographics.org/releases  pixman-0.32.8  tar.gz  true
+}
+
+##### FREETYPE #####
+
+function make_freetype {
+  build_conf_make_inst  http://sourceforge.net/projects/freetype/files/freetype2/2.6.1  freetype-2.6.1  tar.bz2  true
+}
+
+##### EXPAT #####
+
+function make_expat {
+  build_conf_make_inst  http://sourceforge.net/projects/expat/files/expat/2.1.0  expat-2.1.0  tar.gz  true
+}
+
+##### FONTCONFIG #####
+
+function make_fontconfig {
+  make_freetype
+  make_expat
+  # CONFIGURE PARAMETERS
+  # build/install fails without --disable-docs 
+  build_conf_make_inst  http://www.freedesktop.org/software/fontconfig/release  fontconfig-2.11.94  tar.gz  true  --disable-docs
+}
+
+##### ICONV #####
+
+function make_libiconv {
+  build_conf_make_inst  http://ftp.gnu.org/pub/gnu/libiconv  libiconv-1.14  tar.gz  true
+}
+
+##### UNISTRING #####
+
+function make_libunistring {
+  build_conf_make_inst  http://ftp.gnu.org/gnu/libunistring  libunistring-0.9.5  tar.xz  true
+}
+
+##### NCURSES #####
+
+function make_ncurses {
+  # NOTE: ncurses is not required below. This is just kept for documentary purposes in case I need it later.
+  #
+  # NOTE: make install fails building the terminfo database because
+  # : ${TIC_PATH:=unknown} in run_tic.sh
+  # As a result pkg-config .pc files are not generated
+  # Also configure of gettext gives two "considers"
+  # checking where terminfo library functions come from... not found, consider installing GNU ncurses
+  # checking where termcap library functions come from... not found, consider installing GNU ncurses
+  # gettext make/make install work anyway
+  #
+  # CONFIGURE PARAMETERS
+  # --enable-term-driver --enable-sp-funcs is rewuired for mingw (see README.MinGW)
+  # additional changes 
+  # ADD --with-pkg-config
+  # ADD --enable-pc-files
+  # ADD --without-manpages
+  # REM --with-pthread
+  build_conf_make_inst  http://ftp.gnu.org/gnu/ncurses  ncurses-5.9  tar.gz  true  --disable-home-terminfo --enable-reentrant --enable-sp-funcs --enable-term-driver --enable-interop --with-pkg-config --enable-pc-files --without-manpages
+}
+
+##### GETTEXT #####
+
+function make_gettext {
+  # Cygwin packet dependencies: (not 100% sure) libiconv-devel,libunistring-devel,libncurses-devel
+  # Cygwin packet dependencies for gettext users: (not 100% sure) gettext-devel,libgettextpo-devel
+  # gettext configure complains that ncurses is also required, but it builds without it
+  # Ncurses is tricky to install/configure for mingw64, so I dropped ncurses
+  make_libiconv
+  make_libunistring
+  build_conf_make_inst  http://ftp.gnu.org/pub/gnu/gettext  gettext-0.19  tar.gz  true
+}
+
+##### LIBFFI #####
+
+function make_libffi {
+  # NOTE: The official download server is down  ftp://sourceware.org/pub/libffi/libffi-3.2.1.tar.gz
+  build_conf_make_inst  http://www.mirrorservice.org/sites/sourceware.org/pub/libffi  libffi-3.2.1  tar.gz  true
+}
+
+##### LIBEPOXY #####
+
+function make_libepoxy {
+  build_conf_make_inst  https://github.com/anholt/libepoxy/releases/download/v1.3.1  libepoxy-1.3.1  tar.bz2  true
+}
+
+##### LIBPCRE #####
+
+function make_libpcre {
+  build_conf_make_inst  ftp://ftp.csx.cam.ac.uk/pub/software/programming/pcre  pcre-8.39    tar.bz2  true
+}
+
+function make_libpcre2 {
+  build_conf_make_inst  ftp://ftp.csx.cam.ac.uk/pub/software/programming/pcre  pcre2-10.22  tar.bz2  true
+}
+
+##### GLIB #####
+
+function make_glib {
+  # Cygwin packet dependencies: mingw64-x86_64-zlib
+  make_gettext
+  make_libffi
+  make_libpcre
+  # build_conf_make_inst  http://ftp.gnome.org/pub/gnome/sources/glib/2.46  glib-2.46.0  tar.xz  true
+  build_conf_make_inst  http://ftp.gnome.org/pub/gnome/sources/glib/2.47  glib-2.47.5  tar.xz  true
+}
+
+##### ATK #####
+
+function make_atk {
+  make_gettext
+  make_glib
+  build_conf_make_inst  http://ftp.gnome.org/pub/gnome/sources/atk/2.18  atk-2.18.0  tar.xz  true
+}
+
+##### PIXBUF #####
+
+function make_gdk-pixbuf {
+  # Cygwin packet dependencies: mingw64-x86_64-zlib
+  make_libpng
+  make_gettext
+  make_glib
+  # CONFIGURE PARAMETERS
+  # --with-included-loaders=yes statically links the image file format handlers
+  # This avoids "Cannot open pixbuf loader module file '/usr/x86_64-w64-mingw32/sys-root/mingw/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache': No such file or directory"
+  build_conf_make_inst  http://ftp.gnome.org/pub/GNOME/sources/gdk-pixbuf/2.32  gdk-pixbuf-2.32.1  tar.xz  true  --with-included-loaders=yes 
+}
+
+##### CAIRO #####
+
+function make_cairo {
+  # Cygwin packet dependencies: mingw64-x86_64-zlib
+  make_libpng
+  make_glib
+  make_pixman
+  make_fontconfig
+  build_conf_make_inst  http://cairographics.org/releases  cairo-1.14.2  tar.xz  true
+}
+
+##### PANGO #####
+
+function make_pango {
+  make_cairo
+  make_glib
+  make_fontconfig
+  build_conf_make_inst  http://ftp.gnome.org/pub/GNOME/sources/pango/1.38  pango-1.38.0  tar.xz  true
+}
+
+##### GTK2 #####
+
+function patch_gtk2 {
+  rm gtk/gtk.def
+}
+
+function make_gtk2 {
+  # Cygwin packet dependencies: gtk-update-icon-cache
+  if [ "$GTK_FROM_SOURCES" == "Y" ]; then
+    make_glib
+    make_atk
+    make_pango
+    make_gdk-pixbuf
+    make_cairo
+    build_conf_make_inst  http://ftp.gnome.org/pub/gnome/sources/gtk+/2.24  gtk+-2.24.28  tar.xz  patch_gtk2
+  fi
+}
+
+##### GTK3 #####
+
+function make_gtk3 {
+  make_glib
+  make_atk
+  make_pango
+  make_gdk-pixbuf
+  make_cairo
+  make_libepoxy
+  build_conf_make_inst  http://ftp.gnome.org/pub/gnome/sources/gtk+/3.16  gtk+-3.16.7  tar.xz  true
+
+  # make all incl. tests and examples runs through fine
+  # make install fails with issue with 
+  # 
+  # make[5]: Entering directory '/home/soegtrop/GTK/gtk+-3.16.7/demos/gtk-demo'
+  # test -n "" || ../../gtk/gtk-update-icon-cache --ignore-theme-index --force "/usr/x86_64-w64-mingw32/sys-root/mingw/share/icons/hicolor"
+  # gtk-update-icon-cache.exe: Failed to open file /usr/x86_64-w64-mingw32/sys-root/mingw/share/icons/hicolor/.icon-theme.cache : No such file or directory
+  # Makefile:1373: recipe for target 'install-update-icon-cache' failed
+  # make[5]: *** [install-update-icon-cache] Error 1
+  # make[5]: Leaving directory '/home/soegtrop/GTK/gtk+-3.16.7/demos/gtk-demo'
+}
+
+##### LIBXML2 #####
+
+function make_libxml2 {
+  # Cygwin packet dependencies: libtool automake
+  # Note: latest release version 2.9.2 fails during configuring lzma, so using 2.9.1
+  # Note: python binding requires <sys/select.h> which doesn't exist on cygwin
+  if build_prep https://git.gnome.org/browse/libxml2/snapshot  libxml2-2.9.1  tar.xz ; then
+    # ./autogen.sh --build=$BUILD --host=$HOST --target=$TARGET --prefix=$PREFIX --disable-shared --without-python
+    # shared library required by gtksourceview
+    ./autogen.sh --build=$BUILD --host=$HOST --target=$TARGET --prefix=$PREFIX --without-python
+    log1 make $MAKE_OPT all
+    log2 make install
+    log2 make clean
+    build_post
+  fi
+}
+
+##### GTK-SOURCEVIEW2 #####
+
+function make_gtk_sourceview2 {
+  # Cygwin packet dependencies: intltool
+  # gtksourceview-2.11.2 requires GTK2
+  # gtksourceview-2.91.9 requires GTK3
+  # => We use gtksourceview-2.11.2 which seems to be the newest GTK2 based one
+  if [ "$GTK_FROM_SOURCES" == "Y" ]; then
+    make_gtk2
+    make_libxml2
+    build_conf_make_inst  https://download.gnome.org/sources/gtksourceview/2.11  gtksourceview-2.11.2  tar.bz2  true
+  fi
+}
+
+##### FLEXDLL FLEXLINK #####
+
+# Note: there is a circular dependency between flexlink and ocaml (resolved in Ocaml 4.03.)
+# For MinGW it is not even possible to first build an Ocaml without flexlink support,
+# Because Makefile.nt doesn't support this. So we have to use a binary flexlink.
+# One could of cause do a bootstrap run ...
+
+# Install flexdll objects
+
+function install_flexdll {
+  cp flexdll.h /usr/$TARGET_ARCH/sys-root/mingw/include
+  if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then
+    cp flexdll*_mingw.o /usr/$TARGET_ARCH/bin
+    cp flexdll*_mingw.o $PREFIXOCAML/bin
+  elif [ "$TARGET_ARCH" == "x86_64-w64-mingw32" ]; then
+    cp flexdll*_mingw64.o /usr/$TARGET_ARCH/bin
+    cp flexdll*_mingw64.o $PREFIXOCAML/bin
+  else
+    echo "Unknown target architecture"
+    return 1
+  fi
+}
+
+# Install flexlink
+
+function install_flexlink {
+  cp flexlink.exe /usr/$TARGET_ARCH/bin
+    
+  cp flexlink.exe $PREFIXOCAML/bin
+}
+
+# Get binary flexdll flexlink for building OCaml
+# An alternative is to first build an OCaml without shared library support and build flexlink with it
+
+function get_flex_dll_link_bin {
+  if build_prep http://alain.frisch.fr/flexdll flexdll-bin-0.34 zip 1 ; then
+    install_flexdll
+    install_flexlink
+    build_post
+  fi
+}
+
+# Build flexdll and flexlink from sources after building OCaml
+
+function make_flex_dll_link {
+  if build_prep http://alain.frisch.fr/flexdll flexdll-0.34 tar.gz ; then
+    if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then
+      log1 make $MAKE_OPT build_mingw flexlink.exe
+    elif [ "$TARGET_ARCH" == "x86_64-w64-mingw32" ]; then
+      log1 make $MAKE_OPT build_mingw64 flexlink.exe
+    else
+      echo "Unknown target architecture"
+      return 1
+    fi
+    install_flexdll
+    install_flexlink
+    log2 make clean
+    build_post
+  fi
+}
+
+##### LN replacement #####
+
+# Note: this does support symlinks, but symlinks require special user rights on Windows.
+# ocamlbuild uses symlinks to link the executables in the build folder to the base folder.
+# For this purpose hard links are better.
+
+function make_ln {
+  if [ ! -f flagfiles/myln.finished ] ; then
+    touch flagfiles/myln.started
+    mkdir -p myln
+    cd myln
+    cp $PATCHES/ln.c .
+    $TARGET_ARCH-gcc -DUNICODE -D_UNICODE -DIGNORE_SYMBOLIC -mconsole -o ln.exe ln.c 
+    install -D ln.exe $PREFIXCOQ/bin/ln.exe
+    cd ..
+    touch flagfiles/myln.finished
+  fi
+}
+
+##### OCAML #####
+
+function make_ocaml {
+  get_flex_dll_link_bin
+  if build_prep http://caml.inria.fr/pub/distrib/ocaml-4.02 ocaml-4.02.3 tar.gz 1 ; then
+  # if build_prep http://caml.inria.fr/pub/distrib/ocaml-4.01 ocaml-4.01.0 tar.gz 1 ; then
+    # See README.win32
+    cp config/m-nt.h config/m.h
+    cp config/s-nt.h config/s.h
+    if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then
+        cp config/Makefile.mingw config/Makefile
+    elif [ "$TARGET_ARCH" == "x86_64-w64-mingw32" ]; then
+        cp config/Makefile.mingw64 config/Makefile
+    else
+        echo "Unknown target architecture"
+        return 1
+    fi
+
+    # Prefix is fixed in make file - replace it with the real one
+    sed -i "s|^PREFIX=.*|PREFIX=$PREFIXOCAML|" config/Makefile
+    
+    # We don't want to mess up Coq's dirctory structure so put the OCaml library in a separate folder
+    # If we refer to the make variable ${PREFIX} below, camlp4 ends up having a wrong path:
+    # D:\bin\coq64_buildtest_abs_ocaml4\bin>ocamlc -where => D:/bin/coq64_buildtest_abs_ocaml4/libocaml
+    # D:\bin\coq64_buildtest_abs_ocaml4\bin>camlp4 -where => ${PREFIX}/libocaml\camlp4
+    # So we put an explicit path in there
+    sed -i "s|^LIBDIR=.*|LIBDIR=$PREFIXOCAML/libocaml|" config/Makefile
+    
+    # Note: ocaml doesn't support -j 8, so don't pass MAKE_OPT
+    # I verified that 4.02.3 still doesn't support parallel build
+    log2 make world -f Makefile.nt
+    log2 make bootstrap -f Makefile.nt
+    log2 make opt -f Makefile.nt
+    log2 make opt.opt -f Makefile.nt
+    log2 make install -f Makefile.nt
+    # TODO log2 make clean -f Makefile.nt Temporarily disabled for ocamlbuild development
+    
+    # Move license files and other into into special folder
+    if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then
+      mkdir -p $PREFIXOCAML/license_readme/ocaml
+      # 4.01 installs these files, 4.02 doesn't. So delete them and copy them from the sources.
+      rm -f *.txt
+      cp LICENSE      $PREFIXOCAML/license_readme/ocaml/License.txt
+      cp INSTALL      $PREFIXOCAML/license_readme/ocaml/Install.txt
+      cp README       $PREFIXOCAML/license_readme/ocaml/ReadMe.txt
+      cp README.win32 $PREFIXOCAML/license_readme/ocaml/ReadMeWin32.txt
+      cp VERSION      $PREFIXOCAML/license_readme/ocaml/Version.txt
+      cp Changes      $PREFIXOCAML/license_readme/ocaml/Changes.txt
+    fi
+
+    build_post
+  fi
+  make_flex_dll_link
+}
+
+##### FINDLIB Ocaml library manager #####
+
+function make_findlib {
+  make_ocaml
+  if build_prep http://download.camlcity.org/download findlib-1.5.6 tar.gz 1 ; then
+    ./configure -bindir $PREFIXOCAML\\bin -sitelib $PREFIXOCAML\\libocaml\\site-lib -config $PREFIXOCAML\\etc\\findlib.conf
+    # Note: findlib doesn't support -j 8, so don't pass MAKE_OPT
+    log2 make all
+    log2 make opt
+    log2 make install
+    log2 make clean
+    build_post
+  fi
+}
+
+##### MENHIR Ocaml Parser Generator #####
+
+function make_menhir {
+  make_ocaml
+  make_findlib
+  # if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20151112 tar.gz 1 ; then
+  # For Ocaml 4.02
+  # if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20151012 tar.gz 1 ; then
+  # For Ocaml 4.01
+  if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20140422 tar.gz 1 ; then
+    # Note: menhir doesn't support -j 8, so don't pass MAKE_OPT
+    log2 make all PREFIX=$PREFIXOCAML
+    log2 make install PREFIX=$PREFIXOCAML
+    mv $PREFIXOCAML/bin/menhir $PREFIXOCAML/bin/menhir.exe
+    build_post
+  fi
+}
+
+##### CAMLP4 Ocaml Preprocessor #####
+
+function make_camlp4 {
+  # OCaml up to 4.01 includes camlp4, from 4.02 it isn't included
+  # Check if command camlp4 exists, if not build camlp4
+  if ! command camlp4 ; then
+    make_ocaml
+    make_findlib
+    if build_prep https://github.com/ocaml/camlp4/archive 4.02+6 tar.gz 1 camlp4-4.02+6 ; then
+      # See https://github.com/ocaml/camlp4/issues/41#issuecomment-112018910
+      logn configure ./configure
+      # Note: camlp4 doesn't support -j 8, so don't pass MAKE_OPT
+      log2 make all
+      log2 make install
+      log2 make clean
+      build_post
+    fi
+  fi
+}
+
+##### CAMLP5 Ocaml Preprocessor #####
+
+function make_camlp5 {
+  make_ocaml
+  make_findlib
+  if build_prep http://camlp5.gforge.inria.fr/distrib/src camlp5-6.14 tgz 1 ; then
+    logn configure ./configure 
+    # Somehow my virus scanner has the boot.new/SAVED directory locked after the move for a second => repeat until success
+    sed -i 's/mv boot.new boot/until mv boot.new boot; do sleep 1; done/' Makefile
+    log1 make world.opt $MAKE_OPT
+    log2 make install
+    # For some reason gramlib.a is not copied, but it is required by Coq
+    cp lib/gramlib.a $PREFIXOCAML/libocaml/camlp5/
+    log2 make clean
+    build_post
+  fi
+}
+
+##### LABLGTK Ocaml GTK binding #####
+
+# Note: when rebuilding lablgtk by deleting the .finished file,
+# also delete <root>\usr\x86_64-w64-mingw32\sys-root\mingw\lib\site-lib
+# Otherwise make install fails
+
+function make_lablgtk {
+  make_ocaml
+  make_findlib
+  make_camlp4
+  if build_prep https://forge.ocamlcore.org/frs/download.php/1479 lablgtk-2.18.3 tar.gz 1 ; then
+    # configure should be fixed to search for $TARGET_ARCH-pkg-config.exe
+    cp /bin/$TARGET_ARCH-pkg-config.exe  bin_special/pkg-config.exe
+    logn configure ./configure --build=$BUILD --host=$HOST --target=$TARGET --prefix=$PREFIXOCAML
+    
+    # lablgtk shows occasional errors with -j, so don't pass $MAKE_OPT
+    
+    # See https://sympa.inria.fr/sympa/arc/caml-list/2015-10/msg00204.html for the make || true + strip
+    logn make-world-pre make world || true
+    $TARGET_ARCH-strip.exe --strip-unneeded src/dlllablgtk2.dll
+    
+    log2 make world
+    log2 make install
+    log2 make clean
+    build_post
+  fi
+}
+
+##### Ocaml Stdint #####
+
+function make_stdint {
+  make_ocaml
+  make_findlib
+  if build_prep https://github.com/andrenth/ocaml-stdint/archive 0.3.0 tar.gz 1 Stdint-0.3.0; then
+    # Note: the setup gets the proper install path from ocamlfind, but for whatever reason it wants
+    # to create an empty folder in some folder which defaults to C:\Program Files.
+    # The --preifx overrides this. Id didn't see any files created in /tmp/extra.
+    log_1_3 ocaml setup.ml -configure --prefix /tmp/extra
+    log_1_3 ocaml setup.ml -build
+    log_1_3 ocaml setup.ml -install
+    log_1_3 ocaml setup.ml -clean
+    build_post
+  fi
+}
+
+##### COQ #####
+
+# Copy one DLLfrom cygwin MINGW packages to Coq install folder
+
+function copy_coq_dll {
+  if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then
+    cp /usr/${ARCH}-w64-mingw32/sys-root/mingw/bin/$1 $PREFIXCOQ/bin/$1
+  fi
+}
+
+# Copy required DLLs from cygwin MINGW packages to Coq install folder
+
+function copy_coq_dlls {
+  # HOW TO CREATE THE DLL LIST
+  # With the list empty, after the build/install is finished, open coqide in dependency walker.
+  # See http://www.dependencywalker.com/
+  # Make sure to use the 32 bit / 64 bit version of depends matching the target architecture.
+  # Select all missing DLLs from the module list, right click "copy filenames"
+  # Delay loaded DLLs from Windows can be ignored (hour-glass icon at begin of line)
+  # Do this recursively until there are no further missing DLLs (File close + reopen)
+  # For running this quickly, just do "cd coq-<ver> ; call copy_coq_dlls ; cd .." at the end of this script.
+  # Do the same for coqc and ocamlc (usually doesn't result in additional files)
+  
+  copy_coq_dll LIBATK-1.0-0.DLL
+  copy_coq_dll LIBCAIRO-2.DLL
+  copy_coq_dll LIBEXPAT-1.DLL
+  copy_coq_dll LIBFFI-6.DLL
+  copy_coq_dll LIBFONTCONFIG-1.DLL
+  copy_coq_dll LIBFREETYPE-6.DLL
+  copy_coq_dll LIBGDK-WIN32-2.0-0.DLL
+  copy_coq_dll LIBGDK_PIXBUF-2.0-0.DLL
+  copy_coq_dll LIBGIO-2.0-0.DLL
+  copy_coq_dll LIBGLIB-2.0-0.DLL
+  copy_coq_dll LIBGMODULE-2.0-0.DLL
+  copy_coq_dll LIBGOBJECT-2.0-0.DLL
+  copy_coq_dll LIBGTK-WIN32-2.0-0.DLL
+  copy_coq_dll LIBINTL-8.DLL
+  copy_coq_dll LIBPANGO-1.0-0.DLL
+  copy_coq_dll LIBPANGOCAIRO-1.0-0.DLL
+  copy_coq_dll LIBPANGOWIN32-1.0-0.DLL
+  copy_coq_dll LIBPIXMAN-1-0.DLL
+  copy_coq_dll LIBPNG16-16.DLL
+  copy_coq_dll LIBXML2-2.DLL
+  copy_coq_dll ZLIB1.DLL
+
+  # Depends on if GTK is built from sources  
+  if [ "$GTK_FROM_SOURCES" == "Y" ]; then
+    copy_coq_dll libiconv-2.dll
+    copy_coq_dll libpcre-1.dll
+  else
+    copy_coq_dll ICONV.DLL
+    copy_coq_dll LIBBZ2-1.DLL
+    copy_coq_dll LIBGTKSOURCEVIEW-2.0-0.DLL
+    copy_coq_dll LIBHARFBUZZ-0.DLL
+    copy_coq_dll LIBLZMA-5.DLL
+    copy_coq_dll LIBPANGOFT2-1.0-0.DLL
+  fi;
+
+  # Architecture dependent files
+  case $ARCH in
+    x86_64) copy_coq_dll LIBGCC_S_SEH-1.DLL ;;
+    i686)   copy_coq_dll LIBGCC_S_SJLJ-1.DLL ;;
+    *)      false ;;
+  esac
+  
+  # Win pthread version change
+  copy_coq_dll LIBWINPTHREAD-1.DLL
+}
+
+function copy_coq_objects {
+  # copy objects only from folders which exist in the target lib directory
+  find . -type d | while read FOLDER ; do
+    if [ -e $PREFIXCOQ/lib/$FOLDER ] ; then
+      install_glob $FOLDER/'*.cmxa' $PREFIXCOQ/lib/$FOLDER 
+      install_glob $FOLDER/'*.cmi'  $PREFIXCOQ/lib/$FOLDER 
+      install_glob $FOLDER/'*.cma'  $PREFIXCOQ/lib/$FOLDER 
+      install_glob $FOLDER/'*.cmo'  $PREFIXCOQ/lib/$FOLDER 
+      install_glob $FOLDER/'*.a'    $PREFIXCOQ/lib/$FOLDER 
+      install_glob $FOLDER/'*.o'    $PREFIXCOQ/lib/$FOLDER 
+    fi
+  done
+}
+
+# Copy required GTK config and suport files
+
+function copq_coq_gtk {
+  echo 'gtk-theme-name = "MS-Windows"'     >  $PREFIX/etc/gtk-2.0/gtkrc
+  echo 'gtk-fallback-icon-theme = "Tango"' >> $PREFIX/etc/gtk-2.0/gtkrc
+
+  if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then
+    install_glob $PREFIX/etc/gtk-2.0/'*'                            $PREFIXCOQ/gtk-2.0
+    install_glob $PREFIX/share/gtksourceview-2.0/language-specs/'*' $PREFIXCOQ/share/gtksourceview-2.0/language-specs
+    install_glob $PREFIX/share/gtksourceview-2.0/styles/'*'         $PREFIXCOQ/share/gtksourceview-2.0/styles
+    install_rec  $PREFIX/share/themes/ '*'                          $PREFIXCOQ/share/themes
+    
+    # This below item look like a bug in make install
+    if [[ ! $COQ_VERSION == 8.4* ]] ; then
+      mv $PREFIXCOQ/share/coq/*.lang $PREFIXCOQ/share/gtksourceview-2.0/language-specs
+      mv $PREFIXCOQ/share/coq/*.xml  $PREFIXCOQ/share/gtksourceview-2.0/styles
+    fi
+    mkdir -p $PREFIXCOQ/ide
+    mv $PREFIXCOQ/share/coq/*.png  $PREFIXCOQ/ide
+    rmdir $PREFIXCOQ/share/coq
+  fi
+}
+
+# Copy license and other info files
+
+function copy_coq_license {
+  if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then
+    install -D doc/LICENSE                    $PREFIXCOQ/license_readme/coq/LicenseDoc.txt
+    install -D LICENSE                        $PREFIXCOQ/license_readme/coq/License.txt
+    install -D plugins/micromega/LICENSE.sos  $PREFIXCOQ/license_readme/coq/LicenseMicromega.txt
+    install -D README                         $PREFIXCOQ/license_readme/coq/ReadMe.txt || true
+    install -D README.md                      $PREFIXCOQ/license_readme/coq/ReadMe.md || true
+    install -D README.doc                     $PREFIXCOQ/license_readme/coq/ReadMeDoc.txt
+    install -D CHANGES                        $PREFIXCOQ/license_readme/coq/Changes.txt
+    install -D INSTALL                        $PREFIXCOQ/license_readme/coq/Install.txt
+    install -D INSTALL.doc                    $PREFIXCOQ/license_readme/coq/InstallDoc.txt
+    install -D INSTALL.ide                    $PREFIXCOQ/license_readme/coq/InstallIde.txt
+  fi
+}
+
+# Main function for creating Coq
+
+function make_coq {
+  make_ocaml
+  make_lablgtk
+  make_camlp5
+  if 
+    case $COQ_VERSION in
+      git-*) build_prep https://github.com/coq/coq/archive ${COQ_VERSION##git-} zip 1 coq-${COQ_VERSION} ;;
+      *)     build_prep https://coq.inria.fr/distrib/V$COQ_VERSION/files coq-$COQ_VERSION tar.gz ;;
+    esac
+  then
+    if [ "$INSTALLMODE" == "relocatable" ]; then
+      # HACK: for relocatable builds, first configure with ./, then build but before install reconfigure with the real target path
+      logn configure ./configure -debug -with-doc no -prefix ./ -libdir ./lib -mandir ./man
+    elif [ "$INSTALLMODE" == "absolute" ]; then
+      logn configure ./configure -debug -with-doc no -prefix $PREFIXCOQ -libdir $PREFIXCOQ/lib -mandir $PREFIXCOQ/man
+    else
+      logn configure ./configure -debug -with-doc no -prefix $PREFIXCOQ
+    fi
+
+    # The windows resource compiler binary name is hard coded
+    sed -i "s/i686-w64-mingw32-windres/$TARGET_ARCH-windres/" Makefile.build 
+    sed -i "s/i686-w64-mingw32-windres/$TARGET_ARCH-windres/" Makefile.ide || true
+
+    # 8.4x doesn't support parallel make
+    if [[ $COQ_VERSION == 8.4* ]] ; then
+      log1 make
+    else
+      log1 make $MAKE_OPT
+    fi
+    
+    if [ "$INSTALLMODE" == "relocatable" ]; then
+      ./configure -debug -with-doc no -prefix $PREFIXCOQ -libdir $PREFIXCOQ/lib -mandir $PREFIXCOQ/man
+    fi
+
+    log2 make install
+    log1 copy_coq_dlls
+    if [ "$INSTALLOCAML" == "Y" ]; then
+      log1 copy_coq_objects
+    fi
+    
+    copq_coq_gtk
+    copy_coq_license
+
+    # make clean seems to br broken for 8.5pl2
+    # 1.) find | xargs fails on cygwin, can be fixed by sed -i 's|\| xargs rm -f|-exec rm -fv \{\} \+|' Makefile
+    # 2.) clean of test suites fails with "cannot run complexity tests (no bogomips found)"
+    # make clean
+    
+    build_post
+  fi
+}
+
+##### GNU Make for MinGW #####
+
+function make_mingw_make {
+  if build_prep http://ftp.gnu.org/gnu/make make-4.2 tar.bz2 ; then
+    # The config.h.win32 file is fine - don't edit it
+    # We need to copy the mingw gcc here as "gcc" - then the batch file will use it
+    cp /usr/bin/${ARCH}-w64-mingw32-gcc-5.4.0.exe ./gcc.exe
+    # By some magic cygwin bash can run batch files
+    logn build ./build_w32.bat gcc
+    # Copy make to Coq folder
+    cp GccRel/gnumake.exe $PREFIXCOQ/bin/make.exe
+    build_post
+  fi
+}
+
+##### GNU binutils for native OCaml #####
+
+function make_binutils {
+  if build_prep http://ftp.gnu.org/gnu/binutils binutils-2.27 tar.gz ; then
+    logn configure ./configure --build=$BUILD --host=$HOST --target=$TARGET --prefix=$PREFIXCOQ --program-prefix=$TARGET-
+    log1 make $MAKE_OPT
+    log2 make install
+    # log2 make clean
+    build_post
+  fi
+}
+
+##### GNU GCC for native OCaml #####
+
+function make_gcc {
+  # Note: the bz2 file is smaller, but decompressing bz2 really takes ages
+  if build_prep ftp://ftp.fu-berlin.de/unix/languages/gcc/releases/gcc-5.4.0 gcc-5.4.0 tar.gz ; then
+    # This is equivalent to "contrib/download_prerequisites" but uses caching
+    # Update versions when updating gcc version
+    get_expand_source_tar  ftp://gcc.gnu.org/pub/gcc/infrastructure  mpfr-2.4.2 tar.bz2 1 mpfr-2.4.2 mpfr
+    get_expand_source_tar  ftp://gcc.gnu.org/pub/gcc/infrastructure  gmp-4.3.2  tar.bz2 1 gmp-4.3.2  gmp
+    get_expand_source_tar  ftp://gcc.gnu.org/pub/gcc/infrastructure  mpc-0.8.1  tar.gz  1 mpc-0.8.1  mpc
+    get_expand_source_tar  ftp://gcc.gnu.org/pub/gcc/infrastructure  isl-0.14   tar.bz2 1 isl-0.14   isl
+
+    # For whatever reason gcc needs this (although it never puts anything into it)
+    # Error: "The directory that should contain system headers does not exist:"
+    # mkdir -p /mingw/include    without --with-sysroot
+    mkdir -p $PREFIXCOQ/mingw/include
+
+    # See https://gcc.gnu.org/install/configure.html
+    logn configure ./configure --build=$BUILD --host=$HOST --target=$TARGET \
+        --prefix=$PREFIXCOQ --program-prefix=$TARGET- --disable-win32-registry --with-sysroot=$PREFIXCOQ \
+        --enable-languages=c --disable-nls \
+        --disable-libsanitizer --disable-libssp --disable-libquadmath --disable-libgomp --disable-libvtv --disable-lto
+        # --disable-decimal-float seems to be required
+        # --with-sysroot=$PREFIX  results in configure error that this is not an absolute path
+    log1 make $MAKE_OPT
+    log2 make install
+    # log2 make clean
+    build_post
+  fi
+}
+
+##### Get sources for Cygwin MinGW packages #####
+
+function get_cygwin_mingw_sources {
+  if [ ! -f flagfiles/cygwin_mingw_sources.finished ] ; then
+    touch flagfiles/cygwin_mingw_sources.started
+
+    # Find all installed files with mingw in the name and download the corresponding source code file from cygwin
+    # Steps:
+    # grep /etc/setup/installed.db for mingw       => mingw64-x86_64-gcc-g++ mingw64-x86_64-gcc-g++-5.4.0-2.tar.bz2 1
+    # remove archive ending and trailing number    => mingw64-x86_64-gcc-g++ mingw64-x86_64-gcc-g++-5.4.0-2
+    # replace space with /                         => ${ARCHIVE} = mingw64-x86_64-gcc-g++/mingw64-x86_64-gcc-g++-5.4.0-2
+    # escape + signs using ${var//pattern/replace} => ${ARCHIVEESC} = mingw64-x86_64-gcc-g++/mingw64-x86_64-gcc-g\+\+-5.4.0-2
+    # grep cygwin setup.ini for installed line + next line (the -A 1 option includes and "after context" of 1 line)
+    # Note that the folders of the installed binaries and source are different. So we cannot grep just for the source line.
+    # We could strip off the path and just grep for the file, though.
+    # => install: x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-g++/mingw64-x86_64-gcc-g++-5.4.0-2.tar.xz 10163848 2f8cb7ba3e16ac8ce0455af01de490ded09061b1b06a9a8e367426635b5a33ce230e04005f059d4ea7b52580757da1f6d5bae88eba6b9da76d1bd95e8844b705
+    #    source: x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-5.4.0-2-src.tar.xz 95565368 03f22997b7173b243fff65ea46a39613a2e4e75fc7e6cf0fa73b7bcb86071e15ba6d0ca29d330c047fb556a5e684cad57cd2f5adb6e794249e4b01fe27f92c95
+    # Take the 2nd field of the last line          => ${SOURCE} = x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-5.4.0-2-src.tar.xz
+    # Remove that path part                        => ${SOURCEFILE} = mingw64-x86_64-gcc-5.4.0-2-src.tar.xz
+
+    grep "mingw" /etc/setup/installed.db | sed 's/\.tar\.bz2 [0-1]$//' | sed 's/ /\//'  | while read ARCHIVE ; do
+      local ARCHIVEESC=${ARCHIVE//+/\\+}
+      local SOURCE=`egrep -A 1 "install: ($CYGWINARCH|noarch)/release/[-+_/a-z0-9]*$ARCHIVEESC" $TARBALLS/setup.ini | tail -1 | cut -d " " -f 2`
+      local SOURCEFILE=${SOURCE##*/}
+
+      # Get the source file (either from the source cache or online)
+      if [ ! -f $TARBALLS/$SOURCEFILE ] ; then
+        if [ -f $SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE ] ; then
+          cp $SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE $TARBALLS
+        else
+          wget "$CYGWIN_REPOSITORY/$SOURCE"
+          mv $SOURCEFILE $TARBALLS
+          # Save the source archive in the source cache
+          if [ -d $SOURCE_LOCAL_CACHE_CFMT ] ; then
+            cp $TARBALLS/$SOURCEFILE $SOURCE_LOCAL_CACHE_CFMT
+          fi
+        fi
+      fi
+
+    done
+
+    touch flagfiles/cygwin_mingw_sources.finished
+  fi
+}
+
+##### Coq Windows Installer #####
+
+function make_coq_installer {
+  make_coq
+  make_mingw_make
+  get_cygwin_mingw_sources
+
+  # Prepare the file lists for the installer. We created to file list dumps of the target folder during the build:
+  # ocaml: ocaml + menhir + camlp5 + findlib
+  # ocal_coq: as above + coq
+  
+  # Create coq file list as ocaml_coq / ocaml
+  diff_files coq ocaml_coq ocaml
+  
+  # Filter out object files
+  filter_files coq_objects coq '\.(cmxa|cmi|cma|cmo|a|o)$' 
+  
+  # Filter out plugin object files
+  filter_files coq_objects_plugins coq_objects '/lib/plugins/.*\.(cmxa|cmi|cma|cmo|a|o)$'
+  
+  # Coq objects objects required for plugin development = coq objects except those for pre installed plugins
+  diff_files coq_plugindev coq_objects coq_objects_plugins
+  
+  # Coq files, except objects needed only for plugin development
+  diff_files coq_base coq coq_plugindev
+  
+  # Convert section files to NSIS format
+  files_to_nsis coq_base
+  files_to_nsis coq_plugindev
+  files_to_nsis ocaml
+  
+  # Get and extract NSIS Binaries
+  if build_prep http://downloads.sourceforge.net/project/nsis/NSIS%202/2.51 nsis-2.51 zip ; then
+    NSIS=`pwd`/makensis.exe
+    chmod u+x "$NSIS"
+    # Change to Coq folder
+    cd ../coq-${COQ_VERSION}
+    # Copy patched nsi file
+    cp ../patches/coq_new.nsi dev/nsis
+    cp ../patches/StrRep.nsh dev/nsis
+    cp ../patches/ReplaceInFile.nsh dev/nsis
+    VERSION=`grep ^VERSION= config/Makefile | cut -d = -f 2`
+    cd dev/nsis
+    logn nsis-installer "$NSIS" -DVERSION=$VERSION -DARCH=$ARCH -DCOQ_SRC_PATH=$PREFIXCOQ -DCOQ_ICON=..\\..\\ide\\coq.ico coq_new.nsi
+    
+    build_post
+  fi
+}
+
+###################### TOP LEVEL BUILD #####################
+
+make_gtk2
+make_gtk_sourceview2
+
+make_ocaml
+make_findlib
+make_lablgtk
+make_camlp4
+make_camlp5
+make_menhir
+make_stdint
+list_files ocaml
+make_coq
+
+if [ "$INSTALLMAKE" == "Y" ] ; then
+  make_mingw_make
+fi
+
+list_files ocaml_coq
+
+if [ "$MAKEINSTALLER" == "Y" ] ; then
+  make_coq_installer
+fi
+
diff --git a/dev/build/windows/patches_coq/ReplaceInFile.nsh b/dev/build/windows/patches_coq/ReplaceInFile.nsh
new file mode 100644
index 00000000..27c7eb2f
--- /dev/null
+++ b/dev/build/windows/patches_coq/ReplaceInFile.nsh
@@ -0,0 +1,67 @@
+; From NSIS Wiki http://nsis.sourceforge.net/ReplaceInFile
+; Modifications:
+; - Replace only once per line
+; - Don't keep original as .old
+; - Use StrRep instead of StrReplace (seems to be cleaner)
+
+Function Func_ReplaceInFile
+  ClearErrors
+
+  Exch $0      ; REPLACEMENT
+  Exch
+  Exch $1      ; SEARCH_TEXT
+  Exch 2
+  Exch $2      ; SOURCE_FILE
+
+  Push $R0     ; SOURCE_FILE file handle
+  Push $R1     ; temporary file handle
+  Push $R2     ; unique temporary file name
+  Push $R3     ; a line to search and replace / save
+  Push $R4     ; shift puffer
+
+  IfFileExists $2 +1 error          ; Check if file exists and open it
+  FileOpen $R0 $2 "r"
+
+  GetTempFileName $R2               ; Create temporary output file
+  FileOpen $R1 $R2 "w"
+
+  loop:                             ; Loop over lines of file
+    FileRead $R0 $R3                ; Read line
+    IfErrors finished
+    Push "$R3"                      ; Replacine string in line once
+    Push "$1"
+    Push "$0"
+    Call Func_StrRep
+    Pop $R3
+    FileWrite $R1 "$R3"             ; Write result
+  Goto loop
+
+  finished:
+    FileClose $R1                   ; Close files
+    FileClose $R0
+    Delete "$2"                     ; Delete original file and rename temporary file to target
+    Rename "$R2" "$2"
+    ClearErrors
+    Goto out
+
+  error:
+    SetErrors
+
+  out:
+  Pop $R4
+  Pop $R3
+  Pop $R2
+  Pop $R1
+  Pop $R0
+  Pop $2
+  Pop $0
+  Pop $1
+FunctionEnd
+
+!macro ReplaceInFile SOURCE_FILE SEARCH_TEXT REPLACEMENT
+  Push "${SOURCE_FILE}"
+  Push "${SEARCH_TEXT}"
+  Push "${REPLACEMENT}"
+  Call Func_ReplaceInFile
+!macroend
+
diff --git a/dev/build/windows/patches_coq/StrRep.nsh b/dev/build/windows/patches_coq/StrRep.nsh
new file mode 100644
index 00000000..d94a9f88
--- /dev/null
+++ b/dev/build/windows/patches_coq/StrRep.nsh
@@ -0,0 +1,60 @@
+; From NSIS Wiki http://nsis.sourceforge.net/StrRep
+; Slightly modified
+
+Function Func_StrRep
+    Exch $R2 ;new
+    Exch 1
+    Exch $R1 ;old
+    Exch 2
+    Exch $R0 ;string
+    Push $R3
+    Push $R4
+    Push $R5
+    Push $R6
+    Push $R7
+    Push $R8
+    Push $R9
+
+    StrCpy $R3 0
+    StrLen $R4 $R1
+    StrLen $R6 $R0
+    StrLen $R9 $R2
+    loop:
+        StrCpy $R5 $R0 $R4 $R3
+        StrCmp $R5 $R1 found
+        StrCmp $R3 $R6 done
+        IntOp $R3 $R3 + 1 ;move offset by 1 to check the next character
+        Goto loop
+    found:
+        StrCpy $R5 $R0 $R3
+        IntOp $R8 $R3 + $R4
+        StrCpy $R7 $R0 "" $R8
+        StrCpy $R0 $R5$R2$R7
+        StrLen $R6 $R0
+        IntOp $R3 $R3 + $R9 ;move offset by length of the replacement string
+        Goto loop
+    done:
+
+    Pop $R9
+    Pop $R8
+    Pop $R7
+    Pop $R6
+    Pop $R5
+    Pop $R4
+    Pop $R3
+    Push $R0
+    Push $R1
+    Pop $R0
+    Pop $R1
+    Pop $R0
+    Pop $R2
+    Exch $R1
+FunctionEnd
+
+!macro StrRep output string old new
+    Push `${string}`
+    Push `${old}`
+    Push `${new}`
+    Call Func_StrRep
+    Pop ${output}
+!macroend
diff --git a/dev/build/windows/patches_coq/camlp4-4.02+6.patch b/dev/build/windows/patches_coq/camlp4-4.02+6.patch
new file mode 100644
index 00000000..0cdb4a92
--- /dev/null
+++ b/dev/build/windows/patches_coq/camlp4-4.02+6.patch
@@ -0,0 +1,11 @@
+--- camlp4-4.02-6.orig/myocamlbuild.ml	2015-06-17 13:37:36.000000000 +0200
++++ camlp4-4.02+6/myocamlbuild.ml	2016-10-13 13:57:35.512213600 +0200
+@@ -86,7 +86,7 @@
+         let dep = "camlp4"/"boot"/exe in
+         let cmd =
+           let ( / ) = Filename.concat in
+-          "camlp4"/"boot"/exe
++          String.escaped (String.escaped ("camlp4"/"boot"/exe))
+         in
+         (Some dep, cmd)
+     in
diff --git a/dev/build/windows/patches_coq/coq-8.4pl2.patch b/dev/build/windows/patches_coq/coq-8.4pl2.patch
new file mode 100644
index 00000000..45a66d0b
--- /dev/null
+++ b/dev/build/windows/patches_coq/coq-8.4pl2.patch
@@ -0,0 +1,11 @@
+--- configure	2014-04-14 22:28:39.174177924 +0200
++++ configure	2014-04-14 22:29:23.253025166 +0200
+@@ -335,7 +335,7 @@
+   MAKEVERSION=`$MAKE -v | head -1 | cut -d" " -f3`
+   MAKEVERSIONMAJOR=`echo $MAKEVERSION | cut -d. -f1`
+   MAKEVERSIONMINOR=`echo $MAKEVERSION | cut -d. -f2`
+-  if [ "$MAKEVERSIONMAJOR" -eq 3 -a "$MAKEVERSIONMINOR" -ge 81 ]; then
++  if [ "$MAKEVERSIONMAJOR" -eq 3 -a "$MAKEVERSIONMINOR" -ge 81 ] || [ "$MAKEVERSIONMAJOR" -ge 4 ] ; then
+       echo "You have GNU Make $MAKEVERSION. Good!"
+   else
+       OK="no"
\ No newline at end of file
diff --git a/dev/build/windows/patches_coq/coq-8.4pl6.patch b/dev/build/windows/patches_coq/coq-8.4pl6.patch
new file mode 100644
index 00000000..c3b7f857
--- /dev/null
+++ b/dev/build/windows/patches_coq/coq-8.4pl6.patch
@@ -0,0 +1,13 @@
+coq-8.4pl6.orig
+--- coq-8.4pl6.orig/configure	2015-04-09 15:59:35.000000000 +0200
++++ coq-8.4pl6//configure	2016-11-09 13:29:42.235319800 +0100
+@@ -309,9 +309,6 @@
+ # executable extension
+ 
+ case "$ARCH,$CYGWIN" in
+-    win32,yes)
+-      EXE=".exe"
+-      DLLEXT=".so";;
+     win32,*)
+       EXE=".exe"
+       DLLEXT=".dll";;
diff --git a/dev/build/windows/patches_coq/coq_new.nsi b/dev/build/windows/patches_coq/coq_new.nsi
new file mode 100644
index 00000000..b88aa066
--- /dev/null
+++ b/dev/build/windows/patches_coq/coq_new.nsi
@@ -0,0 +1,223 @@
+; This script is used to build the Windows install program for Coq.
+
+; NSIS Modern User Interface
+; Written by Joost Verburg
+; Modified by Julien Narboux, Pierre Letouzey, Enrico Tassi and Michael Soegtrop
+
+; The following command line defines are expected:
+; VERSION      Coq version, e.g. 8.5-pl2
+; ARCH         The target architecture, either x86_64 or i686
+; COQ_SRC_PATH path of Coq installation in Windows or MinGW format (either \\ or /, but with drive letter)
+; COQ_ICON     path of Coq icon file in Windows or MinGW format
+
+; Enable compression after debugging.
+; SetCompress off
+SetCompressor lzma
+
+!define MY_PRODUCT "Coq" ;Define your own software name here
+!define OUTFILE "coq-installer-${VERSION}-${ARCH}.exe"
+
+!include "MUI2.nsh"
+!include "FileAssociation.nsh"
+!include "StrRep.nsh"
+!include "ReplaceInFile.nsh"
+!include "winmessages.nsh"
+
+Var COQ_SRC_PATH_BS   ; COQ_SRC_PATH with \ instead of /
+Var COQ_SRC_PATH_DBS  ; COQ_SRC_PATH with \\ instead of /
+Var INSTDIR_DBS       ; INSTDIR with \\ instead of \
+
+;--------------------------------
+;Configuration
+
+  Name "Coq"
+
+  ;General
+  OutFile "${OUTFILE}"
+
+  ;Folder selection page
+  InstallDir "C:\${MY_PRODUCT}"
+  
+  ;Remember install folder
+  InstallDirRegKey HKCU "Software\${MY_PRODUCT}" ""
+
+;--------------------------------
+;Modern UI Configuration
+  
+  !define MUI_ICON "${COQ_ICON}"
+
+  !insertmacro MUI_PAGE_WELCOME
+  !insertmacro MUI_PAGE_LICENSE "${COQ_SRC_PATH}/license_readme/coq/License.txt"
+  !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 an OCaml compiler for Coq native compute and plugin development."
+  LangString DESC_3 ${LANG_ENGLISH} "This package contains the development files needed in order to build a plugin for Coq."
+  LangString DESC_4 ${LANG_ENGLISH} "Set the OCAMLLIB environment variable for the current user."
+  LangString DESC_5 ${LANG_ENGLISH} "Set the OCAMLLIB environment variable for all users."
+
+;--------------------------------
+; 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\"
+  !include "..\..\..\filelists\coq_base.nsh"
+
+  ${registerExtension} "$INSTDIR\bin\coqide.exe" ".v" "Coq Script File"
+
+  ;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"
+
+  ; Create start menu entries
+  ; SetOutPath is required for the path in the .lnk files
+  SetOutPath "$INSTDIR" 
+  CreateDirectory "$SMPROGRAMS\Coq"
+  ; The first shortcut set here is treated as main application by Windows 7/8.
+  ; Use CoqIDE as main application
+  CreateShortCut "$SMPROGRAMS\Coq\CoqIde.lnk" "$INSTDIR\bin\coqide.exe"
+  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
+
+;OCAML Section "Ocaml for native compute and plugin development" Sec2
+;OCAML   SetOutPath "$INSTDIR\"
+;OCAML   !include "..\..\..\filelists\ocaml.nsh"
+;OCAML 
+;OCAML   ; Create a few slash / backslash variants of the source and install path
+;OCAML   ; Note: NSIS has variables, written as $VAR and defines, written as ${VAR}
+;OCAML   !insertmacro StrRep $COQ_SRC_PATH_BS  ${COQ_SRC_PATH} "/" "\"
+;OCAML   !insertmacro StrRep $COQ_SRC_PATH_DBS ${COQ_SRC_PATH} "/" "\\"
+;OCAML   !insertmacro StrRep $INSTDIR_DBS      $INSTDIR        "\" "\\"
+;OCAML 
+;OCAML   ; Replace absolute paths in some OCaml config files
+;OCAML   ; These are not all, see ReadMe.txt
+;OCAML   !insertmacro ReplaceInFile "$INSTDIR\libocaml\ld.conf" "/"  "\"
+;OCAML   !insertmacro ReplaceInFile "$INSTDIR\libocaml\ld.conf" "$COQ_SRC_PATH_BS"  "$INSTDIR"
+;OCAML   !insertmacro ReplaceInFile "$INSTDIR\etc\findlib.conf" "$COQ_SRC_PATH_DBS" "$INSTDIR_DBS"
+;OCAML SectionEnd
+ 
+Section "Coq files for plugin developers" Sec3
+  SetOutPath "$INSTDIR\"
+  !include "..\..\..\filelists\coq_plugindev.nsh"
+SectionEnd
+
+;OCAML Section "OCAMLLIB current user" Sec4
+;OCAML    WriteRegStr HKCU "Environment" "OCAMLLIB" "$INSTDIR\libocaml"
+;OCAML    ; This is required, so that a newly started shell gets the new environment variable
+;OCAML    ; But it really takes a few seconds
+;OCAML    DetailPrint "Broadcasting OCAMLLIB environment variable change (current user)"
+;OCAML    SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=1000
+;OCAML SectionEnd
+
+;OCAML Section "OCAMLLIB all users" Sec5
+;OCAML    WriteRegStr HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment" "OCAMLLIB" "$INSTDIR\libocaml"
+;OCAML    ; This is required, so that a newly started shell gets the new environment variable
+;OCAML    ; But it really takes a few seconds
+;OCAML    DetailPrint "Broadcasting OCAMLLIB environment variable change (all users)"
+;OCAML    SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=1000
+;OCAML SectionEnd
+
+;--------------------------------
+;Descriptions
+
+!insertmacro MUI_FUNCTION_DESCRIPTION_BEGIN
+  !insertmacro MUI_DESCRIPTION_TEXT ${Sec1} $(DESC_1)
+  ;OCAML !insertmacro MUI_DESCRIPTION_TEXT ${Sec2} $(DESC_2)
+  !insertmacro MUI_DESCRIPTION_TEXT ${Sec3} $(DESC_3)
+  ;OCAML !insertmacro MUI_DESCRIPTION_TEXT ${Sec4} $(DESC_4)
+  ;OCAML !insertmacro MUI_DESCRIPTION_TEXT ${Sec5} $(DESC_5)
+!insertmacro MUI_FUNCTION_DESCRIPTION_END
+ 
+;--------------------------------
+;Uninstaller Section
+
+Section "Uninstall"
+  ; Files and folders
+  RMDir /r "$INSTDIR\bin"
+  RMDir /r "$INSTDIR\dev"
+  RMDir /r "$INSTDIR\etc"
+  RMDir /r "$INSTDIR\lib"
+  RMDir /r "$INSTDIR\libocaml"
+  RMDir /r "$INSTDIR\share"
+  RMDir /r "$INSTDIR\ide"
+  RMDir /r "$INSTDIR\gtk-2.0"
+  RMDir /r "$INSTDIR\latex"
+  RMDir /r "$INSTDIR\license_readme"
+  RMDir /r "$INSTDIR\man"
+  RMDir /r "$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"
+  
+  ; Registry keys
+  DeleteRegKey HKCU "Software\${MY_PRODUCT}"
+  DeleteRegKey HKLM "SOFTWARE\Coq"
+  DeleteRegKey HKLM "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\Coq"
+  DeleteRegKey HKCU "Environment\OCAMLLIB"
+  DeleteRegKey HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment\OCAMLLIB"
+  ${unregisterExtension} ".v" "Coq Script File"
+
+  ; Root folders
+  RMDir "$INSTDIR"
+  RMDir "$SMPROGRAMS\Coq"
+
+SectionEnd
diff --git a/dev/build/windows/patches_coq/flexdll-0.34.patch b/dev/build/windows/patches_coq/flexdll-0.34.patch
new file mode 100644
index 00000000..16389bac
--- /dev/null
+++ b/dev/build/windows/patches_coq/flexdll-0.34.patch
@@ -0,0 +1,14 @@
+reloc.ml
+--- orig.flexdll-0.34/reloc.ml	2015-01-22 17:30:07.000000000 +0100
++++ flexdll-0.34/reloc.ml	2016-10-12 11:59:16.885829700 +0200
+@@ -117,8 +117,8 @@
+ 
+ let new_cmdline () =
+   let rf = match !toolchain with
+-  | `MSVC | `MSVC64 | `LIGHTLD -> true
+-  | `MINGW | `MINGW64 | `GNAT | `CYGWIN | `CYGWIN64 -> false
++  | `MSVC | `MSVC64 | `LIGHTLD | `MINGW | `MINGW64 -> true
++  | `GNAT | `CYGWIN | `CYGWIN64 -> false
+   in
+   {
+    may_use_response_file = rf;
diff --git a/dev/build/windows/patches_coq/glib-2.46.0.patch b/dev/build/windows/patches_coq/glib-2.46.0.patch
new file mode 100644
index 00000000..9082460b
--- /dev/null
+++ b/dev/build/windows/patches_coq/glib-2.46.0.patch
@@ -0,0 +1,30 @@
+diff -u -r glib-2.46.0/gio/glocalfile.c glib-2.46.0.patched/gio/glocalfile.c
+--- glib-2.46.0/gio/glocalfile.c	2015-08-27 05:32:26.000000000 +0200
++++ glib-2.46.0.patched/gio/glocalfile.c	2016-01-27 13:08:30.059736400 +0100
+@@ -2682,7 +2682,10 @@
+         (!g_path_is_absolute (filename) || len > g_path_skip_root (filename) - filename))
+       wfilename[len] = '\0';
+ 
+-    retval = _wstat32i64 (wfilename, &buf);
++    // MSoegtrop: _wstat32i64 is the wrong function for GLocalFileStat = struct _stati64
++    // The correct function is _wstati64, see https://msdn.microsoft.com/en-us/library/14h5k7ff.aspx
++    // Also _wstat32i64 is a VC function, not a windows SDK function, see https://msdn.microsoft.com/en-us/library/aa273365(v=vs.60).aspx
++    retval = _wstati64 (wfilename, &buf);
+     save_errno = errno;
+ 
+     g_free (wfilename);
+diff -u -r glib-2.46.0/glib/gstdio.c glib-2.46.0.patched/glib/gstdio.c
+--- glib-2.46.0/glib/gstdio.c	2015-02-26 13:57:09.000000000 +0100
++++ glib-2.46.0.patched/glib/gstdio.c	2016-01-27 13:31:12.708987700 +0100
+@@ -493,7 +493,10 @@
+       (!g_path_is_absolute (filename) || len > g_path_skip_root (filename) - filename))
+     wfilename[len] = '\0';
+ 
+-  retval = _wstat (wfilename, buf);
++  // MSoegtrop: _wstat32i64 is the wrong function for GLocalFileStat = struct _stati64
++  // The correct function is _wstati64, see https://msdn.microsoft.com/en-us/library/14h5k7ff.aspx
++  // Also _wstat32i64 is a VC function, not a windows SDK function, see https://msdn.microsoft.com/en-us/library/aa273365(v=vs.60).aspx
++  retval = _wstati64 (wfilename, buf);
+   save_errno = errno;
+ 
+   g_free (wfilename);
diff --git a/dev/build/windows/patches_coq/gtksourceview-2.11.2.patch b/dev/build/windows/patches_coq/gtksourceview-2.11.2.patch
new file mode 100644
index 00000000..73a098d1
--- /dev/null
+++ b/dev/build/windows/patches_coq/gtksourceview-2.11.2.patch
@@ -0,0 +1,213 @@
+diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourceiter.c gtksourceview-2.11.2.patched/gtksourceview/gtksourceiter.c
+*** gtksourceview-2.11.2.orig/gtksourceview/gtksourceiter.c	2010-05-30 12:24:14.000000000 +0200
+--- gtksourceview-2.11.2.patched/gtksourceview/gtksourceiter.c	2015-10-27 14:58:54.422888400 +0100
+***************
+*** 80,86 ****
+  	/* If string contains prefix, check that prefix is not followed
+  	 * by a unicode mark symbol, e.g. that trailing 'a' in prefix
+  	 * is not part of two-char a-with-hat symbol in string. */
+! 	return type != G_UNICODE_COMBINING_MARK &&
+  		type != G_UNICODE_ENCLOSING_MARK &&
+  		type != G_UNICODE_NON_SPACING_MARK;
+  }
+--- 80,86 ----
+  	/* If string contains prefix, check that prefix is not followed
+  	 * by a unicode mark symbol, e.g. that trailing 'a' in prefix
+  	 * is not part of two-char a-with-hat symbol in string. */
+! 	return type != G_UNICODE_SPACING_MARK &&
+  		type != G_UNICODE_ENCLOSING_MARK &&
+  		type != G_UNICODE_NON_SPACING_MARK;
+  }
+diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.c gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.c
+*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.c	2010-05-30 12:24:14.000000000 +0200
+--- gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.c	2015-10-27 14:55:30.294477600 +0100
+***************
+*** 274,280 ****
+   * containg a list of language files directories.
+   * The array is owned by @lm and must not be modified.
+   */
+! G_CONST_RETURN gchar* G_CONST_RETURN *
+  gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm)
+  {
+  	g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL);
+--- 274,280 ----
+   * containg a list of language files directories.
+   * The array is owned by @lm and must not be modified.
+   */
+! const gchar* const *
+  gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm)
+  {
+  	g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL);
+***************
+*** 392,398 ****
+   * available languages or %NULL if no language is available. The array
+   * is owned by @lm and must not be modified.
+   */
+! G_CONST_RETURN gchar* G_CONST_RETURN *
+  gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm)
+  {
+  	g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL);
+--- 392,398 ----
+   * available languages or %NULL if no language is available. The array
+   * is owned by @lm and must not be modified.
+   */
+! const gchar* const *
+  gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm)
+  {
+  	g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL);
+diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.h gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.h
+*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.h	2009-11-15 00:41:33.000000000 +0100
+--- gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.h	2015-10-27 14:55:30.518500000 +0100
+***************
+*** 62,74 ****
+  
+  GtkSourceLanguageManager *gtk_source_language_manager_get_default		(void);
+  
+! G_CONST_RETURN gchar* G_CONST_RETURN *
+  			  gtk_source_language_manager_get_search_path		(GtkSourceLanguageManager *lm);
+  
+  void			  gtk_source_language_manager_set_search_path		(GtkSourceLanguageManager *lm,
+  										 gchar                   **dirs);
+  
+! G_CONST_RETURN gchar* G_CONST_RETURN *
+  			  gtk_source_language_manager_get_language_ids		(GtkSourceLanguageManager *lm);
+  
+  GtkSourceLanguage	 *gtk_source_language_manager_get_language		(GtkSourceLanguageManager *lm,
+--- 62,74 ----
+  
+  GtkSourceLanguageManager *gtk_source_language_manager_get_default		(void);
+  
+! const gchar* const *
+  			  gtk_source_language_manager_get_search_path		(GtkSourceLanguageManager *lm);
+  
+  void			  gtk_source_language_manager_set_search_path		(GtkSourceLanguageManager *lm,
+  										 gchar                   **dirs);
+  
+! const gchar* const *
+  			  gtk_source_language_manager_get_language_ids		(GtkSourceLanguageManager *lm);
+  
+  GtkSourceLanguage	 *gtk_source_language_manager_get_language		(GtkSourceLanguageManager *lm,
+diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.c gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.c
+*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.c	2010-05-30 12:24:14.000000000 +0200
+--- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.c	2015-10-27 14:55:30.545502700 +0100
+***************
+*** 310,316 ****
+   *
+   * Since: 2.0
+   */
+! G_CONST_RETURN gchar* G_CONST_RETURN *
+  gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme)
+  {
+  	g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME (scheme), NULL);
+--- 310,316 ----
+   *
+   * Since: 2.0
+   */
+! const gchar* const *
+  gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme)
+  {
+  	g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME (scheme), NULL);
+***************
+*** 318,324 ****
+  	if (scheme->priv->authors == NULL)
+  		return NULL;
+  
+! 	return (G_CONST_RETURN gchar* G_CONST_RETURN *)scheme->priv->authors->pdata;
+  }
+  
+  /**
+--- 318,324 ----
+  	if (scheme->priv->authors == NULL)
+  		return NULL;
+  
+! 	return (const gchar* const *)scheme->priv->authors->pdata;
+  }
+  
+  /**
+diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.h gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.h
+*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.h	2010-03-29 15:02:56.000000000 +0200
+--- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.h	2015-10-27 14:55:30.565504700 +0100
+***************
+*** 61,67 ****
+  const gchar             *gtk_source_style_scheme_get_name       (GtkSourceStyleScheme *scheme);
+  const gchar             *gtk_source_style_scheme_get_description(GtkSourceStyleScheme *scheme);
+  
+! G_CONST_RETURN gchar* G_CONST_RETURN *
+  			 gtk_source_style_scheme_get_authors	(GtkSourceStyleScheme *scheme);
+  
+  const gchar             *gtk_source_style_scheme_get_filename	(GtkSourceStyleScheme *scheme);
+--- 61,67 ----
+  const gchar             *gtk_source_style_scheme_get_name       (GtkSourceStyleScheme *scheme);
+  const gchar             *gtk_source_style_scheme_get_description(GtkSourceStyleScheme *scheme);
+  
+! const gchar* const *
+  			 gtk_source_style_scheme_get_authors	(GtkSourceStyleScheme *scheme);
+  
+  const gchar             *gtk_source_style_scheme_get_filename	(GtkSourceStyleScheme *scheme);
+diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.c gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.c
+*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.c	2010-05-30 12:24:14.000000000 +0200
+--- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.c	2015-10-27 14:55:30.583506500 +0100
+***************
+*** 515,521 ****
+   * of string containing the search path.
+   * The array is owned by the @manager and must not be modified.
+   */
+! G_CONST_RETURN gchar* G_CONST_RETURN *
+  gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager)
+  {
+  	g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL);
+--- 515,521 ----
+   * of string containing the search path.
+   * The array is owned by the @manager and must not be modified.
+   */
+! const gchar* const *
+  gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager)
+  {
+  	g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL);
+***************
+*** 554,560 ****
+   * of string containing the ids of the available style schemes or %NULL if no
+   * style scheme is available. The array is owned by the @manager and must not be modified.
+   */
+! G_CONST_RETURN gchar* G_CONST_RETURN *
+  gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager)
+  {
+  	g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL);
+--- 554,560 ----
+   * of string containing the ids of the available style schemes or %NULL if no
+   * style scheme is available. The array is owned by the @manager and must not be modified.
+   */
+! const gchar* const *
+  gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager)
+  {
+  	g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL);
+diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.h gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.h
+*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.h	2009-11-15 00:41:33.000000000 +0100
+--- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.h	2015-10-27 14:56:24.498897500 +0100
+***************
+*** 73,84 ****
+  void 			 gtk_source_style_scheme_manager_prepend_search_path   (GtkSourceStyleSchemeManager	*manager,
+  						    				 const gchar			*path);
+  
+! G_CONST_RETURN gchar* G_CONST_RETURN *
+  			 gtk_source_style_scheme_manager_get_search_path	(GtkSourceStyleSchemeManager	*manager);
+  
+  void			 gtk_source_style_scheme_manager_force_rescan		(GtkSourceStyleSchemeManager	*manager);
+  
+! G_CONST_RETURN gchar* G_CONST_RETURN *
+  			 gtk_source_style_scheme_manager_get_scheme_ids		(GtkSourceStyleSchemeManager	*manager);
+  
+  GtkSourceStyleScheme	*gtk_source_style_scheme_manager_get_scheme		(GtkSourceStyleSchemeManager	*manager,
+--- 73,84 ----
+  void 			 gtk_source_style_scheme_manager_prepend_search_path   (GtkSourceStyleSchemeManager	*manager,
+  						    				 const gchar			*path);
+  
+! const gchar* const *
+  			 gtk_source_style_scheme_manager_get_search_path	(GtkSourceStyleSchemeManager	*manager);
+  
+  void			 gtk_source_style_scheme_manager_force_rescan		(GtkSourceStyleSchemeManager	*manager);
+  
+! const gchar* const *
+  			 gtk_source_style_scheme_manager_get_scheme_ids		(GtkSourceStyleSchemeManager	*manager);
+  
+  GtkSourceStyleScheme	*gtk_source_style_scheme_manager_get_scheme		(GtkSourceStyleSchemeManager	*manager,
diff --git a/dev/build/windows/patches_coq/isl-0.14.patch b/dev/build/windows/patches_coq/isl-0.14.patch
new file mode 100644
index 00000000..f3b8ead1
--- /dev/null
+++ b/dev/build/windows/patches_coq/isl-0.14.patch
@@ -0,0 +1,11 @@
+--- orig.isl-0.14/configure	2014-10-26 08:36:32.000000000 +0100
++++ isl-0.14/configure	2016-10-10 18:16:01.430224500 +0200
+@@ -8134,7 +8134,7 @@
+      lt_sysroot=`$CC --print-sysroot 2>/dev/null`
+    fi
+    ;; #(
+- /*)
++ /*|[A-Z]:\\*|[A-Z]:/*)
+    lt_sysroot=`echo "$with_sysroot" | sed -e "$sed_quote_subst"`
+    ;; #(
+  no|'')
diff --git a/dev/build/windows/patches_coq/lablgtk-2.18.3.patch b/dev/build/windows/patches_coq/lablgtk-2.18.3.patch
new file mode 100644
index 00000000..0691c1fc
--- /dev/null
+++ b/dev/build/windows/patches_coq/lablgtk-2.18.3.patch
@@ -0,0 +1,87 @@
+diff -u -r lablgtk-2.18.3/configure lablgtk-2.18.3.patched/configure
+--- lablgtk-2.18.3/configure	2014-10-29 08:51:05.000000000 +0100
++++ lablgtk-2.18.3.patched/configure	2015-10-29 08:58:08.543985500 +0100
+@@ -2667,7 +2667,7 @@
+ fi
+ 
+ 
+-if test "`$OCAMLFIND printconf stdlib`" != "`$CAMLC -where`"; then
++if test "`$OCAMLFIND printconf stdlib | tr '\\' '/'`" != "`$CAMLC -where | tr '\\' '/'`"; then
+   { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Ignoring ocamlfind" >&5
+ $as_echo "$as_me: WARNING: Ignoring ocamlfind" >&2;}
+   OCAMLFIND=no
+
+diff -u -r lablgtk-2.18.3/src/glib.mli lablgtk-2.18.3.patched/src/glib.mli
+--- lablgtk-2.18.3/src/glib.mli	2014-10-29 08:51:06.000000000 +0100
++++ lablgtk-2.18.3.patched/src/glib.mli	2016-01-25 09:50:59.884715200 +0100
+@@ -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
+
+diff -u -r lablgtk-2.18.3/src/glib.ml lablgtk-2.18.3.patched/src/glib.ml
+--- lablgtk-2.18.3/src/glib.ml	2014-10-29 08:51:06.000000000 +0100
++++ lablgtk-2.18.3.patched/src/glib.ml	2016-01-25 09:50:59.891715900 +0100
+@@ -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
+
+diff -u -r lablgtk-2.18.3/src/ml_glib.c lablgtk-2.18.3.patched/src/ml_glib.c
+--- lablgtk-2.18.3/src/ml_glib.c	2014-10-29 08:51:06.000000000 +0100
++++ lablgtk-2.18.3.patched/src/ml_glib.c	2016-01-25 09:50:59.898716600 +0100
+@@ -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,
diff --git a/dev/build/windows/patches_coq/ln.c b/dev/build/windows/patches_coq/ln.c
new file mode 100644
index 00000000..5e02c72b
--- /dev/null
+++ b/dev/build/windows/patches_coq/ln.c
@@ -0,0 +1,137 @@
+// (C) 2016 Intel Deutschland GmbH
+// Author: Michael Soegtrop
+// Released to the public under CC0
+// See https://creativecommons.org/publicdomain/zero/1.0/
+
+// Windows drop in repacement for Linux ln
+// Supports command form "ln TARGET LINK_NAME"
+// Supports -s and -f options
+// Does not support hard links to folders (but symlinks are ok)
+
+#include <windows.h>
+#include <stdio.h>
+#include <tchar.h>
+
+// Cygwin MinGW doesn't have this Vista++ function in windows.h
+#ifdef UNICODE
+    WINBASEAPI BOOLEAN APIENTRY CreateSymbolicLinkW ( LPCWSTR, LPCWSTR, DWORD );
+    #define CreateSymbolicLink  CreateSymbolicLinkW
+    #define CommandLineToArgv CommandLineToArgvW
+#else
+    WINBASEAPI BOOLEAN APIENTRY CreateSymbolicLinkA ( LPCSTR, LPCSTR, DWORD );
+    #define CreateSymbolicLink  CreateSymbolicLinkA
+    #define CommandLineToArgv CommandLineToArgvA
+#endif
+#define SYMBOLIC_LINK_FLAG_DIRECTORY 1
+
+int WINAPI WinMain( HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLineA, int nShowCmd )
+{
+    int iarg;
+    BOOL symbolic = FALSE;
+    BOOL force = FALSE;
+    BOOL folder;
+    const _TCHAR *target;
+    const _TCHAR *link;
+    LPTSTR lpCmdLine; 
+    int argc;
+    LPTSTR *argv;
+
+    // Parse command line
+    // This is done explicitly here for two reasons
+    // 1.) MinGW doesn't seem to support _tmain, wWinMain and the like
+    // 2.) We want to make sure that CommandLineToArgv is used
+    lpCmdLine = GetCommandLine();
+    argv = CommandLineToArgv( lpCmdLine, &argc );
+    
+    // Get target and link name
+    if( argc<3 )
+    {
+        _ftprintf( stderr, _T("Expecting at least 2 arguments, got %d\n"), argc-1 );
+        return 1;
+    }
+    target = argv[argc-2];
+    link = argv[argc-1];
+
+    // Parse options
+    // The last two arguments are interpreted as file names
+    // All other arguments must be -s or -f os multi letter options like -sf
+    for(iarg=1; iarg<argc-2; iarg++ )
+    {
+        const _TCHAR *pos = argv[iarg]; 
+        if( *pos != _T('-') )
+        {
+            _ftprintf( stderr, _T("Command line option expected in argument %d\n"), iarg );
+            return 1;
+        }
+        pos ++;
+
+        while( *pos )
+        {
+            switch( *pos )
+            {
+                case _T('s') : symbolic = TRUE; break;
+                case _T('f') : force = TRUE; break;
+                default : 
+                    _ftprintf( stderr, _T("Unknown option '%c'\n"), *pos );
+                    return 1;
+            }
+            pos ++;
+        }
+    }
+    
+    #ifdef IGNORE_SYMBOLIC
+        symbolic = FALSE;
+    #endif
+    
+    // Check if link already exists - delete it if force is given or abort
+    {
+        if( GetFileAttributes(link) != INVALID_FILE_ATTRIBUTES )
+        {
+            if( force )
+            {
+                if( !DeleteFile( link ) )
+                {
+                    _ftprintf( stderr, _T("Error deleting file '%s'\n"), link );
+                    return 1;
+                }
+            }
+            else
+            {
+                _ftprintf( stderr, _T("File '%s' exists!\n"), link );
+                return 1;
+            }
+        }
+    }
+    
+    // Check if target is a folder
+    folder = ( (GetFileAttributes(target) & FILE_ATTRIBUTE_DIRECTORY) ) != 0;
+    
+    // Create link
+    if(symbolic)
+    {
+        if( !CreateSymbolicLink( link, target, folder ? SYMBOLIC_LINK_FLAG_DIRECTORY : 0 ) )
+        {
+            _ftprintf( stderr, _T("Error creating symbolic link '%s' -> '%s'!\n"), link, target );
+            return 1;
+        }
+    }
+    else
+    {
+        if( folder )
+        {
+            _ftprintf( stderr, _T("Cannot create hard link to folder") );
+            return 1;
+        }
+        else
+        {
+            if( !CreateHardLink( link, target, NULL ) )
+            {
+                _ftprintf( stderr, _T("Error creating hard link '%s' -> '%s'!\n"), link, target );
+                return 1;
+            }
+        }
+    }
+    
+    // Everything is fine
+    return 0;
+}
\ No newline at end of file
diff --git a/dev/db b/dev/db
index 36a171af..f226291d 100644
--- a/dev/db
+++ b/dev/db
@@ -11,6 +11,7 @@ install_printer Top_printers.ppexistentialset
 install_printer Top_printers.ppintset
 install_printer Top_printers.pplab
 install_printer Top_printers.ppdir
+install_printer Top_printers.ppmbid
 install_printer Top_printers.ppmp
 install_printer Top_printers.ppkn
 install_printer Top_printers.ppcon
@@ -50,6 +51,7 @@ install_printer Top_printers.prsubst
 install_printer Top_printers.prdelta
 install_printer Top_printers.ppfconstr
 install_printer Top_printers.ppgenarginfo
+install_printer Top_printers.ppgenargargt
 install_printer Top_printers.ppist
 install_printer Top_printers.ppconstrunderbindersidmap
 install_printer Top_printers.ppunbound_ltac_var_map
diff --git a/dev/doc/README-V1-V5 b/dev/doc/README-V1-V5
deleted file mode 100644
index ebbc0577..00000000
--- a/dev/doc/README-V1-V5
+++ /dev/null
@@ -1,296 +0,0 @@
-
-                 Notes on the prehistory of Coq
-
-This document is a copy within the Coq archive of a document written
-in September 2015 by Gérard Huet, Thierry Coquand and Christine Paulin
-to accompany their public release of the archive of versions 1.10 to 6.2
-of Coq and of its CONSTR ancestor. CONSTR, then Coq, was designed and
-implemented in the Formel team, joint between the INRIA Rocquencourt
-laboratory and the Ecole Normale Supérieure of Paris, from 1984
-onwards.
-
-Version 1
-
-This software is a prototype type-checker for a higher-order logical formalism
-known as the Theory of Constructions, presented in his PhD thesis by
-Thierry Coquand, with influences from Girard's system F and de Bruijn's Automath.
-The metamathematical analysis of the system is the
-PhD work of Thierry Coquand. The software is mostly the work of Gérard Huet.
-Most of the mathematical examples verified with the software are due
-to Thierry Coquand.
-
-The programming language of the CONSTR software (as it was called at the time)
-is a version of ML issued from the Edinburgh LCF system and running on
-a LISP backend. The main improvements from the original LCF ML are that ML
-is compiled rather than interpreted (Gérard Huet building on the original
-translator by Lockwood Morris), and that it is enriched by recursively
-defined types (work of Guy Cousineau). This ancestor of CAML was used
-and improved by Larry Paulson for his implementation of Cambridge LCF.
-
-Software developments of this prototype occurred from late 1983 to early 1985.
-
-Version 1.10 was frozen on December 22nd 1984. It is the version used for the
-examples in Thierry Coquand's thesis, defended on January 31st 1985.
-There was a unique binding operator, used both for universal quantification
-(dependent product) at the level of types and functional abstraction (lambda)
-at the level of terms/proofs, in the manner of Automath. Substitution
-(lambda reduction) was implemented using de Bruijn's indexes.
-
-Version 1.11 was frozen on February 19th, 1985. It is the version used for the
-examples in the paper:
-Th. Coquand, G. Huet. Constructions: A Higher Order Proof System for Mechanizing
-Mathematics. Invited paper, EUROCAL85, April 1985, Linz, Austria. Springer Verlag
-LNCS 203, pp. 151-184.
-
-Christine Paulin joined the team at this point, for her DEA research internship.
-In her DEA memoir (August 1985) she presents developments for the lambo function
-computing the minimal m such that f(m) is greater than n, for f an increasing
-integer function, a challenge for constructive mathematics. She also encoded
-the majority voting algorithm of Boyer and Moore.
-
-Version 2
-
-The formal system, now renamed as the "Calculus of Constructions", was presented
-with a proof of consistency and comparisons with proof systems of Per
-Martin Löf, Girard, and the Automath family of N. de Bruijn, in the paper:
-T. Coquand and G. Huet. The Calculus of Constructions.
-Submitted on June 30th 1985, accepted on December 5th, 1985,
-Information and Computation. Preprint as Rapport de Recherche Inria n°530,
-Mai 1986. Final version in Information and Computation 76,2/3, Feb. 88.
-
-An abstraction of the software design, in the form of an abstract machine
-for proof checking, and a fuller sequence of mathematical developments was
-presented in:
-Th. Coquand, G. Huet. Concepts Mathématiques et Informatiques Formalisés dans le Calcul des Constructions. Invited paper, European Logic Colloquium, Orsay,
-July 1985. Preprint as Rapport de recherche INRIA n°463, Dec. 85.
-Published in Logic Colloquium 1985, North-Holland, 1987.
-
-Version 2.8 was frozen on December 16th, 1985, and served for developing
-the exemples in the above papers.
-
-This calculus was then enriched in version 2.9 with a cumulative hierarchy of
-universes. Universe levels were initially explicit natural numbers.
-Another improvement was the possibility of automatic synthesis of implicit
-type arguments, relieving the user of tedious redundant declarations.
-
-Christine Paulin wrote an article "Algorithm development in the Calculus of
-Constructions", preprint as Rapport de recherche INRIA n°497, March 86.
-Final version in Proceedings Symposium on Logic in Computer Science, Cambridge,
-MA, 1986 (IEEE Computer Society Press). Besides lambo and majority,
-she presents quicksort and a text formatting algorithm.
-
-Version 2.13 of the calculus of constructions with universes was frozen
-on June 25th, 1986.
-
-A synthetic presentation of type theory along constructive lines with ML
-algorithms was given by Gérard Huet in his May 1986 CMU course notes
-"Formal Structures for Computation and Deduction". Its chapter
-"Induction and Recursion in the Theory of Constructions" was presented
-as an invited paper at the Joint Conference on Theory and Practice of Software
-Development TAPSOFT’87 at Pise in March 1987, and published as
-"Induction Principles Formalized in the Calculus of Constructions" in
-Programming of Future Generation Computers, Ed. K. Fuchi and M. Nivat,
-North-Holland, 1988.
-
-Version 3
-
-This version saw the beginning of proof automation, with a search algorithm
-inspired from PROLOG and the applicative logic programming programs
-of the course notes "Formal structures for computation and deduction".
-The search algorithm was implemented in ML by Thierry Coquand.
-The proof system could thus be used in two modes: proof verification and
-proof synthesis, with tactics such as "AUTO".
-
-The implementation language was now called CAML, for "categorical abstract
-machine language". It used as backend the LLM3 virtual machine of Le Lisp
-by Jérôme Chailloux. The main developers of CAML were Michel Mauny,
-Ascander Suarez and Pierre Weis.
-
-V3.1 was started in the summer of 1986, V3.2 was frozen at the end of November
-1986. V3.4 was developed in the first half of 1987.
-
-Thierry Coquand held a post-doctoral position in Cambrige University in 1986-87,
-where he developed a variant implementation in SML, with which he wrote
-some developments on fixpoints in Scott's domains.
-
-Version 4
-
-This version saw the beginning of program extraction from proofs, with
-two varieties of the type Prop of propositions, indicating constructive intent.
-The proof extraction algorithms were implemented by Christine Paulin-Mohring.
-
-V4.1 was frozen on July 24th, 1987. It had a first identified library of
-mathematical developments (directory exemples), with libraries Logic
-(containing impredicative encodings of intuitionistic logic and algebraic
-primitives for booleans, natural numbers and list), Peano developing second-order
-Peano arithmetic, Arith defining addition, multiplication, euclidean division
-and factorial. Typical developments were the Knaster-Tarski theorem
-and Newman's lemma from rewriting theory.
-
-V4.2 was a joint development of a team consisting of Thierry Coquand, Gérard
-Huet and Christine Paulin-Mohring. A file V4.2.log records the log of changes.
-It was frozen on September 1987 as the last version implemented in CAML 2.3,
-and V4.3 followed on CAML 2.5, a more stable development system.
-
-V4.3 saw the first top-level of the system. Instead of evaluating explicit
-quotations, the user could develop his mathematics in a high-level language
-called the mathematical vernacular (following Automath terminology).
-The user could develop files in the vernacular notation (with .v extension)
-which were now separate from the ml sources of the implementation.
-Gilles Dowek joined the team to develop the vernacular language as his
-DEA internship research.
-
-A notion of sticky constant was introduced, in order to keep names of lemmas
-when local hypotheses of proofs were discharged. This gave a notion
-of global mathematical environment with local sections.
-
-Another significant practical change was that the system, originally developped
-on the VAX central computer of our lab, was transferred on SUN personal
-workstations, allowing a level of distributed development.
-The extraction algorithm was modified, with three annotations Pos, Null and
-Typ decorating the sorts Prop and Type.
-
-Version 4.3 was frozen at the end of November 1987, and was distributed to an
-early community of users (among those were Hugo Herbelin and Loic Colson).
-
-V4.4 saw the first version of (encoded) inductive types.
-Now natural numbers could be defined as:
-Inductive NAT : Prop = O : NAT | Succ : NAT->NAT.
-These inductive types were encoded impredicatively in the calculus,
-using a subsystem "rec" due to Christine Paulin.
-V4.4 was frozen on March 6th 1988.
-
-Version 4.5 was the first one to support inductive types and program extraction.
-Its banner was "Calcul des Constructions avec Realisations et Synthese".
-The vernacular language was enriched to accommodate extraction commands.
-
-The verification engine design was presented as:
-G. Huet. The Constructive Engine. Version 4.5. Invited Conference, 2nd European
-Symposium on Programming, Nancy, March 88.
-The final paper, describing the V4.9 implementation, appeared in:
-A perspective in Theoretical Computer Science, Commemorative Volume in memory
-of Gift Siromoney, Ed. R. Narasimhan, World Scientific Publishing, 1989.
-
-Version 4.5 was demonstrated in June 1988 at the YoP Institute on Logical
-Foundations of Functional Programming organized by Gérard Huet at Austin, Texas.
-
-Version 4.6 was started during summer 1988. Its main improvement was the
-complete rehaul of the proof synthesis engine by Thierry Coquand, with
-a tree structure of goals.
-
-Its source code was communicated to Randy Pollack on September 2nd 1988.
-It evolved progressively into LEGO, proof system for Luo's formalism
-of Extended Calculus of Constructions.
-
-The discharge tactic was modified by G. Huet to allow for inter-dependencies
-in discharged lemmas. Christine Paulin improved the inductive definition scheme
-in order to accommodate predicates of any arity.
-
-Version 4.7 was started on September 6th, 1988.
-
-This version starts exploiting the CAML notion of module in order to improve the
-modularity of the implementation. Now the term verifier is identified as
-a proper module Machine, which the structure of its internal data structures
-being hidden and thus accessible only through the legitimate operations.
-This machine (the constructive engine) was the trusted core of the
-implementation. The proof synthesis mechanism was a separate proof term
-generator. Once a complete proof term was synthesized with the help of tactics,
-it was entirely re-checked by the engine. Thus there was no need to certify
-the tactics, and the system took advantage of this fact by having tactics ignore
-the universe levels, universe consistency check being relegated to the final
-type-checking pass. This induced a certain puzzlement of early users who saw
-their successful proof search ended with QED, followed by silence, followed by
-a failure message of universe inconsistency rejection...
-
-The set of examples comprise set theory experiments by Hugo Herbelin,
-and notably the Schroeder-Bernstein theorem.
-
-Version 4.8, started on October 8th, 1988, saw a major re-implementation of the
-abstract syntax type constr, separating variables of the formalism and
-metavariables denoting incomplete terms managed by the search mechanism.
-A notion of level (with three values TYPE, OBJECT and PROOF) is made explicit
-and a type judgement clarifies the constructions, whose implementation is now
-fully explicit. Structural equality is speeded up by using pointer equality,
-yielding spectacular improvements. Thierry Coquand adapts the proof synthesis
-to the new representation, and simplifies pattern matching to 1st order
-predicate calculus matching, with important performance gain.
-
-A new representation of the universe hierarchy is then defined by G. Huet.
-Universe levels are now implemented implicitly, through a hidden graph
-of abstract levels constrained with an order relation.
-Checking acyclicity of the graph insures well-foundedness of the ordering,
-and thus consistency. This was documented in a memo
-"Adding Type:Type to the Calculus of Constructions" which was never published.
-
-The development version is released as a stable 4.8 at the end of 1988.
-
-Version 4.9 is released on March 1st 1989, with the new "elastic"
-universe hierarchy.
-
-The spring 89 saw the first attempt at documenting the system usage,
-with a number of papers describing the formalism:
-- Metamathematical Investigations of a Calculus of Constructions, by
-Thierry Coquand (INRIA Research Report N°1088, Sept. 1989, published in
-Logic and Computer Science, ed. P.G. Odifreddi, Academic Press, 1990)
-- Inductive definitions in the Calculus of Constructions, by
-Christine Paulin-Mohring,
-- Extracting Fomega's programs from proofs in the Calculus of Constructions, by
-Christine Paulin-Mohring (published in POPL'89)
-- The Constructive Engine, by Gérard Huet
-as well as a number of user guides:
-- A short user's guide for the Constructions Version 4.10, by Gérard Huet
-- A Vernacular Syllabus, by Gilles Dowek.
-- The Tactics Theorem Prover, User's guide, Version 4.10, by Thierry Coquand.
-
-Stable V4.10, released on May 1st, 1989, was then a mature system,
-distributed with CAML V2.6.
-
-In the mean time, Thierry Coquand and Christine Paulin-Mohring
-had been investigating how to add native inductive types to the
-Calculus of Constructions, in the manner of Per Martin-Löf's Intuitionistic
-Type Theory. The impredicative encoding had already been presented in:
-F. Pfenning and C. Paulin-Mohring. Inductively defined types in the Calculus
-of Constructions. Preprint technical report CMU-CS-89-209, final version in
-Proceedings of Mathematical Foundations of Programming Semantics,
-volume 442, Lecture Notes in Computer Science. Springer-Verlag, 1990.
-An extension of the calculus with primitive inductive types appeared in:
-Th. Coquand and C. Paulin-Mohring. Inductively defined types.
-In P. Martin-Löf and G. Mints, editors, Proceedings of Colog'88, volume 417,
-Lecture Notes in Computer Science. Springer-Verlag, 1990.
-
-This lead to the Calculus of Inductive Constructions, logical formalism
-implemented in Versions 5 upward of the system, and documented in:
-C. Paulin-Mohring. Inductive Definitions in the System Coq - Rules and
-Properties. In M. Bezem and J.-F. Groote, editors, Proceedings of the conference
-Typed Lambda Calculi and Applications, volume 664, Lecture Notes in Computer
-Science, 1993.
-
-The last version of CONSTR is Version 4.11, which was last distributed
-in Spring 1990. It was demonstrated at the first workshop of the European
-Basic Research Action Logical Frameworks In Sophia Antipolis in May 1990.
-
-At the end of 1989, Version 5.1 was started, and renamed as the system Coq
-for the Calculus of Inductive Constructions. It was then ported to the new
-stand-alone implementation of ML called Caml-light.
-
-In 1990 many changes occurred. Thierry Coquand left for Chalmers University
-in Göteborg. Christine Paulin-Mohring took a CNRS researcher position
-at the LIP laboratory of Ecole Normale Supérieure de Lyon. Project Formel
-was terminated, and gave rise to two teams: Cristal at INRIA-Roquencourt,
-that continued developments in functional programming with Caml-light then
-Ocaml, and Coq, continuing the type theory research, with a joint team
-headed by Gérard Huet at INRIA-Rocquencourt and Christine Paulin-Mohring
-at the LIP laboratory of CNRS-ENS Lyon.
-
-Chetan Murthy joined the team in 1991 and became the main software architect
-of Version 5. He completely rehauled the implementation for efficiency.
-Versions 5.6 and 5.8 were major distributed versions, with complete
-documentation and a library of users' developements. The use of the RCS
-revision control system, and systematic ChangeLog files, allow a more
-precise tracking of the software developments.
-
-Developments from Version 6 upwards are documented in the credits section of
-Coq's Reference Manual.
-
-September 2015
-Thierry Coquand, Gérard Huet and Christine Paulin-Mohring.
diff --git a/dev/doc/README-V1-V5.asciidoc b/dev/doc/README-V1-V5.asciidoc
new file mode 100644
index 00000000..631fb92c
--- /dev/null
+++ b/dev/doc/README-V1-V5.asciidoc
@@ -0,0 +1,378 @@
+Notes on the prehistory of Coq
+==============================
+:author:  Thierry Coquand, Gérard Huet & Christine Paulin-Mohring
+:revdate: September 2015
+:toc:
+:toc-placement: preamble
+:toclevels: 1
+:showtitle:
+
+
+This document is a copy within the Coq archive of a document written
+in September 2015 by Gérard Huet, Thierry Coquand and Christine Paulin
+to accompany their public release of the archive of versions 1.10 to 6.2
+of Coq and of its CONSTR ancestor. CONSTR, then Coq, was designed and
+implemented in the Formel team, joint between the INRIA Rocquencourt
+laboratory and the Ecole Normale Supérieure of Paris, from 1984
+onwards.
+
+Version 1
+---------
+
+This software is a prototype type-checker for a higher-order logical
+formalism known as the Theory of Constructions, presented in his PhD
+thesis by Thierry Coquand, with influences from Girard's system F and
+de Bruijn's Automath.  The metamathematical analysis of the system is
+the PhD work of Thierry Coquand. The software is mostly the work of
+Gérard Huet.  Most of the mathematical examples verified with the
+software are due to Thierry Coquand.
+
+The programming language of the CONSTR software (as it was called at
+the time) was a version of ML adapted from the Edinburgh LCF system
+and running on a LISP backend. The main improvements from the original
+LCF ML were that ML was compiled rather than interpreted (Gérard Huet
+building on the original translator by Lockwood Morris), and that it
+was enriched by recursively defined types (work of Guy
+Cousineau). This ancestor of CAML was used and improved by Larry
+Paulson for his implementation of Cambridge LCF.
+
+Software developments of this prototype occurred from late 1983 to
+early 1985.
+
+Version 1.10 was frozen on December 22nd 1984. It is the version used
+for the examples in Thierry Coquand's thesis, defended on January 31st
+1985.  There was a unique binding operator, used both for universal
+quantification (dependent product) at the level of types and
+functional abstraction (λ) at the level of terms/proofs, in the manner
+of Automath. Substitution (λ-reduction) was implemented using de
+Bruijn's indexes.
+
+Version 1.11 was frozen on February 19th, 1985. It is the version used
+for the examples in the paper: Th. Coquand, G. Huet. __Constructions: A
+Higher Order Proof System for Mechanizing Mathematics__ <<CH85>>.
+
+Christine Paulin joined the team at this point, for her DEA research
+internship.  In her DEA memoir (August 1985) she presents developments
+for the _lambo_ function – _lambo(f)(n)_ computes the minimal _m_ such
+that _f(m)_ is greater than _n_, for _f_ an increasing integer
+function, a challenge for constructive mathematics. She also encoded
+the majority voting algorithm of Boyer and Moore.
+
+Version 2
+---------
+
+The formal system, now renamed as the _Calculus of Constructions_, was
+presented with a proof of consistency and comparisons with proof
+systems of Per Martin Löf, Girard, and the Automath family of N. de
+Bruijn, in the paper: T. Coquand and G. Huet. __The Calculus of
+Constructions__ <<CH88>>.
+
+An abstraction of the software design, in the form of an abstract
+machine for proof checking, and a fuller sequence of mathematical
+developments was presented in: Th. Coquand, G. Huet. __Concepts
+Mathématiques et Informatiques Formalisés dans le Calcul des
+Constructions__<<CH87>>.
+
+Version 2.8 was frozen on December 16th, 1985, and served for
+developing the exemples in the above papers.
+
+This calculus was then enriched in version 2.9 with a cumulative
+hierarchy of universes. Universe levels were initially explicit
+natural numbers.  Another improvement was the possibility of automatic
+synthesis of implicit type arguments, relieving the user of tedious
+redundant declarations.
+
+Christine Paulin wrote an article __Algorithm development in the
+Calculus of Constructions__ <<P86>>. Besides _lambo_ and _majority_,
+she presents quicksort and a text formatting algorithm.
+
+Version 2.13 of the Calculus of Constructions with universes was
+frozen on June 25th, 1986.
+
+A synthetic presentation of type theory along constructive lines with
+ML algorithms was given by Gérard Huet in his May 1986 CMU course
+notes _Formal Structures for Computation and Deduction_. Its chapter
+_Induction and Recursion in the Theory of Constructions_ was presented
+as an invited paper at the Joint Conference on Theory and Practice of
+Software Development TAPSOFT’87 at Pise in March 1987, and published
+as __Induction Principles Formalized in the Calculus of
+Constructions__ <<H88>>.
+
+Version 3
+---------
+
+This version saw the beginning of proof automation, with a search
+algorithm inspired from PROLOG and the applicative logic programming
+programs of the course notes _Formal structures for computation and
+deduction_.  The search algorithm was implemented in ML by Thierry
+Coquand.  The proof system could thus be used in two modes: proof
+verification and proof synthesis, with tactics such as `AUTO`.
+
+The implementation language was now called CAML, for Categorical
+Abstract Machine Language. It used as backend the LLM3 virtual machine
+of Le Lisp by Jérôme Chailloux. The main developers of CAML were
+Michel Mauny, Ascander Suarez and Pierre Weis.
+
+V3.1 was started in the summer of 1986, V3.2 was frozen at the end of
+November 1986. V3.4 was developed in the first half of 1987.
+
+Thierry Coquand held a post-doctoral position in Cambrige University
+in 1986-87, where he developed a variant implementation in SML, with
+which he wrote some developments on fixpoints in Scott's domains.
+
+Version 4
+---------
+
+This version saw the beginning of program extraction from proofs, with
+two varieties of the type `Prop` of propositions, indicating
+constructive intent.  The proof extraction algorithms were implemented
+by Christine Paulin-Mohring.
+
+V4.1 was frozen on July 24th, 1987. It had a first identified library
+of mathematical developments (directory exemples), with libraries
+Logic (containing impredicative encodings of intuitionistic logic and
+algebraic primitives for booleans, natural numbers and list), `Peano`
+developing second-order Peano arithmetic, `Arith` defining addition,
+multiplication, euclidean division and factorial. Typical developments
+were the Knaster-Tarski theorem and Newman's lemma from rewriting
+theory.
+
+V4.2 was a joint development of a team consisting of Thierry Coquand,
+Gérard Huet and Christine Paulin-Mohring. A file V4.2.log records the
+log of changes.  It was frozen on September 1987 as the last version
+implemented in CAML 2.3, and V4.3 followed on CAML 2.5, a more stable
+development system.
+
+V4.3 saw the first top-level of the system. Instead of evaluating
+explicit quotations, the user could develop his mathematics in a
+high-level language called the mathematical vernacular (following
+Automath terminology).  The user could develop files in the vernacular
+notation (with .v extension) which were now separate from the `ml`
+sources of the implementation.  Gilles Dowek joined the team to
+develop the vernacular language as his DEA internship research.
+
+A notion of sticky constant was introduced, in order to keep names of
+lemmas when local hypotheses of proofs were discharged. This gave a
+notion of global mathematical environment with local sections.
+
+Another significant practical change was that the system, originally
+developped on the VAX central computer of our lab, was transferred on
+SUN personal workstations, allowing a level of distributed
+development.  The extraction algorithm was modified, with three
+annotations `Pos`, `Null` and `Typ` decorating the sorts `Prop` and
+`Type`.
+
+Version 4.3 was frozen at the end of November 1987, and was
+distributed to an early community of users (among those were Hugo
+Herbelin and Loic Colson).
+
+V4.4 saw the first version of (encoded) inductive types.  Now natural
+numbers could be defined as:
+
+[source, coq]
+Inductive NAT : Prop = O : NAT | Succ : NAT->NAT.
+
+These inductive types were encoded impredicatively in the calculus,
+using a subsystem _rec_ due to Christine Paulin.  V4.4 was frozen on
+March 6th 1988.
+
+Version 4.5 was the first one to support inductive types and program
+extraction.  Its banner was _Calcul des Constructions avec
+Réalisations et Synthèse_.  The vernacular language was enriched to
+accommodate extraction commands.
+
+The verification engine design was presented as: G. Huet. _The
+Constructive Engine_. Version 4.5. Invited Conference, 2nd European
+Symposium on Programming, Nancy, March 88.  The final paper,
+describing the V4.9 implementation, appeared in: A perspective in
+Theoretical Computer Science, Commemorative Volume in memory of Gift
+Siromoney, Ed. R. Narasimhan, World Scientific Publishing, 1989.
+
+Version 4.5 was demonstrated in June 1988 at the YoP Institute on
+Logical Foundations of Functional Programming organized by Gérard Huet
+at Austin, Texas.
+
+Version 4.6 was started during the summer of 1988. Its main
+improvement was the complete rehaul of the proof synthesis engine by
+Thierry Coquand, with a tree structure of goals.
+
+Its source code was communicated to Randy Pollack on September 2nd
+1988.  It evolved progressively into LEGO, proof system for Luo's
+formalism of Extended Calculus of Constructions.
+
+The discharge tactic was modified by Gérard Huet to allow for
+inter-dependencies in discharged lemmas. Christine Paulin improved the
+inductive definition scheme in order to accommodate predicates of any
+arity.
+
+Version 4.7 was started on September 6th, 1988.
+
+This version starts exploiting the CAML notion of module in order to
+improve the modularity of the implementation. Now the term verifier is
+identified as a proper module Machine, which the structure of its
+internal data structures being hidden and thus accessible only through
+the legitimate operations.  This machine (the constructive engine) was
+the trusted core of the implementation. The proof synthesis mechanism
+was a separate proof term generator. Once a complete proof term was
+synthesized with the help of tactics, it was entirely re-checked by
+the engine. Thus there was no need to certify the tactics, and the
+system took advantage of this fact by having tactics ignore the
+universe levels, universe consistency check being relegated to the
+final type-checking pass. This induced a certain puzzlement in early
+users who saw, after a successful proof search, their `QED` followed
+by silence, followed by a failure message due to a universe
+inconsistency…
+
+The set of examples comprise set theory experiments by Hugo Herbelin,
+and notably the Schroeder-Bernstein theorem.
+
+Version 4.8, started on October 8th, 1988, saw a major
+re-implementation of the abstract syntax type `constr`, separating
+variables of the formalism and metavariables denoting incomplete terms
+managed by the search mechanism.  A notion of level (with three values
+`TYPE`, `OBJECT` and `PROOF`) is made explicit and a type judgement
+clarifies the constructions, whose implementation is now fully
+explicit. Structural equality is speeded up by using pointer equality,
+yielding spectacular improvements. Thierry Coquand adapts the proof
+synthesis to the new representation, and simplifies pattern matching
+to first-order predicate calculus matching, with important performance
+gain.
+
+A new representation of the universe hierarchy is then defined by
+Gérard Huet.  Universe levels are now implemented implicitly, through
+a hidden graph of abstract levels constrained with an order relation.
+Checking acyclicity of the graph insures well-foundedness of the
+ordering, and thus consistency. This was documented in a memo _Adding
+Type:Type to the Calculus of Constructions_ which was never published.
+
+The development version is released as a stable 4.8 at the end of
+1988.
+
+Version 4.9 is released on March 1st 1989, with the new ``elastic''
+universe hierarchy.
+
+The spring of 1989 saw the first attempt at documenting the system
+usage, with a number of papers describing the formalism:
+
+- _Metamathematical Investigations of a Calculus of Constructions_, by
+  Thierry Coquand <<C90>>,
+- _Inductive definitions in the Calculus of Constructions_, by
+   Christine Paulin-Mohrin,
+- _Extracting Fω's programs from proofs in the Calculus of
+  Constructions_, by Christine Paulin-Mohring <<P89>>,
+- _The Constructive Engine_, by Gérard Huet <<H89>>,
+
+as well as a number of user guides:
+
+- _A short user's guide for the Constructions_ Version 4.10, by Gérard Huet
+- _A Vernacular Syllabus_, by Gilles Dowek.
+- _The Tactics Theorem Prover, User's guide_, Version 4.10, by Thierry
+  Coquand.
+
+Stable V4.10, released on May 1st, 1989, was then a mature system,
+distributed with CAML V2.6.
+
+In the mean time, Thierry Coquand and Christine Paulin-Mohring had
+been investigating how to add native inductive types to the Calculus
+of Constructions, in the manner of Per Martin-Löf's Intuitionistic
+Type Theory. The impredicative encoding had already been presented in:
+F. Pfenning and C. Paulin-Mohring. __Inductively defined types in the
+Calculus of Constructions__ <<PP90>>. An extension of the calculus
+with primitive inductive types appeared in: Th. Coquand and
+C. Paulin-Mohring. __Inductively defined types__ <<CP90>>.
+
+This led to the Calculus of Inductive Constructions, logical formalism
+implemented in Versions 5 upward of the system, and documented in:
+C. Paulin-Mohring. __Inductive Definitions in the System Coq - Rules
+and Properties__ <<P93>>.
+
+The last version of CONSTR is Version 4.11, which was last distributed
+in the spring of 1990. It was demonstrated at the first workshop of
+the European Basic Research Action Logical Frameworks In Sophia
+Antipolis in May 1990.
+
+At the end of 1989, Version 5.1 was started, and renamed as the system
+Coq for the Calculus of Inductive Constructions. It was then ported to
+the new stand-alone implementation of ML called Caml-light.
+
+In 1990 many changes occurred. Thierry Coquand left for Chalmers
+University in Göteborg. Christine Paulin-Mohring took a CNRS
+researcher position at the LIP laboratory of École Normale Supérieure
+de Lyon. Project Formel was terminated, and gave rise to two teams:
+Cristal at INRIA-Roquencourt, that continued developments in
+functional programming with Caml-light then Ocaml, and Coq, continuing
+the type theory research, with a joint team headed by Gérard Huet at
+INRIA-Rocquencourt and Christine Paulin-Mohring at the LIP laboratory
+of CNRS-ENS Lyon.
+
+Chetan Murthy joined the team in 1991 and became the main software
+architect of Version 5. He completely rehauled the implementation for
+efficiency.  Versions 5.6 and 5.8 were major distributed versions,
+with complete documentation and a library of users' developements. The
+use of the RCS revision control system, and systematic ChangeLog
+files, allow a more precise tracking of the software developments.
+
+Developments from Version 6 upwards are documented in the credits
+section of Coq's Reference Manual.
+
+====
+September 2015 +
+Thierry Coquand, Gérard Huet and Christine Paulin-Mohring.
+====
+
+[bibliography]
+.Bibliographic references
+
+- [[[CH85]]] Th. Coquand, G. Huet. _Constructions: A Higher Order
+  Proof System for Mechanizing Mathematics_. Invited paper, EUROCAL85,
+  April 1985, Linz, Austria. Springer Verlag LNCS 203, pp. 151-184.
+
+- [[[CH88]]] T. Coquand and G. Huet. _The Calculus of Constructions_.
+  Submitted on June 30th 1985, accepted on December 5th, 1985,
+  Information and Computation. Preprint as Rapport de Recherche Inria
+  n°530, Mai 1986. Final version in Information and Computation
+  76,2/3, Feb. 88.
+
+- [[[CH87]]] Th. Coquand, G. Huet. _Concepts Mathématiques et
+  Informatiques Formalisés dans le Calcul des Constructions_. Invited
+  paper, European Logic Colloquium, Orsay, July 1985. Preprint as
+  Rapport de recherche INRIA n°463, Dec. 85.  Published in Logic
+  Colloquium 1985, North-Holland, 1987.
+
+- [[[P86]]] C. Paulin. _Algorithm development in the Calculus of
+  Constructions_, preprint as Rapport de recherche INRIA n°497,
+  March 86. Final version in Proceedings Symposium on Logic in Computer
+  Science, Cambridge, MA, 1986 (IEEE Computer Society Press).
+
+- [[[H88]]] G. Huet. _Induction Principles Formalized in the Calculus
+  of Constructions_ in Programming of Future Generation Computers,
+  Ed. K. Fuchi and M. Nivat, North-Holland, 1988.
+
+- [[[C90]]] Th. Coquand. _Metamathematical Investigations of a
+  Calculus of Constructions_, by INRIA Research Report N°1088,
+  Sept. 1989, published in Logic and Computer Science,
+  ed. P.G. Odifreddi, Academic Press, 1990.
+
+- [[[P89]]] C. Paulin. _Extracting F ω's programs from proofs in the
+  calculus of constructions_. 16th Annual ACM Symposium on Principles
+  of Programming Languages, Austin. 1989.
+
+- [[[H89]]] G. Huet. _The constructive engine_. A perspective in
+  Theoretical Computer Science. Commemorative Volume for Gift
+  Siromoney. World Scientific Publishing (1989).
+
+- [[[PP90]]] F. Pfenning and C. Paulin-Mohring. _Inductively defined
+  types in the Calculus of Constructions_. Preprint technical report
+  CMU-CS-89-209, final version in Proceedings of Mathematical
+  Foundations of Programming Semantics, volume 442, Lecture Notes in
+  Computer Science. Springer-Verlag, 1990
+
+- [[[CP90]]] Th. Coquand and C. Paulin-Mohring. _Inductively defined
+  types_.  In P. Martin-Löf and G. Mints, editors, Proceedings of
+  Colog'88, volume 417, Lecture Notes in Computer Science.
+  Springer-Verlag, 1990.
+
+- [[[P93]]] C. Paulin-Mohring. _Inductive Definitions in the System
+  Coq - Rules and Properties_. In M. Bezem and J.-F. Groote, editors,
+  Proceedings of the conference Typed Lambda Calculi and Applications,
+  volume 664, Lecture Notes in Computer Science, 1993.
diff --git a/dev/doc/build-system.dev.txt b/dev/doc/build-system.dev.txt
index af1120e9..fefcb093 100644
--- a/dev/doc/build-system.dev.txt
+++ b/dev/doc/build-system.dev.txt
@@ -30,6 +30,11 @@ HISTORY:
     restricted set of .ml4 (see variable BUILDGRAMMAR).
   - then on the true target asked by the user.
 
+* June 2016 (Pierre Letouzey)
+  The files in grammar/ are now self-contained, we could compile
+  grammar.cma (and q_constr.cmo) directly, no need for a separate
+  subcall to make nor awkward include-failed-and-retry.
+
     
 ---------------------------------------------------------------------------
 
@@ -59,29 +64,14 @@ Cons:
 Makefiles hierachy
 ------------------
 
-Le Makefile a été séparé en plusieurs fichiers :
-
-- 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 : 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
----------------
+The Makefile is separated in several files :
 
-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.
+- Makefile: wrapper that triggers a call to Makefile.build, except for
+  clean and a few other little things doable without dependency analysis.
+- Makefile.common : variable definitions (mostly lists of files or
+  directories)
+- Makefile.build : contains compilation rules, and the "include" of dependencies
+- Makefile.doc : specific rules for compiling the documentation.
 
 
 FIND_VCS_CLAUSE
diff --git a/dev/doc/build-system.txt b/dev/doc/build-system.txt
index 31d9875a..873adc1b 100644
--- a/dev/doc/build-system.txt
+++ b/dev/doc/build-system.txt
@@ -113,15 +113,20 @@ Targets for cleaning various parts:
 
  - docclean: clean documentation
 
-.ml4 files
-----------
+.ml4/.mlp files
+---------------
 
-If a .ml4 file uses a grammar extension from Coq (such as grammar.cma
-or q_constr.cmo), it must contain a line like:
+There is now two kinds of preprocessed files : 
+ - a .mlp do not need grammar.cma (they are in grammar/)
+ - a .ml4 is now always preprocessed with grammar.cma (and q_constr.cmo),
+   except coqide_main.ml4 and its specific rule
+
+This classification replaces the old mechanism of declaring the use
+of a grammar extension via a line of the form:
  (*i camlp4deps: "grammar.cma q_constr.cmo" i*)
 
 The use of (*i camlp4use: ... i*) to mention uses of standard
-extension such as IFDEF has been discontinued, the Makefile now
+extension such as IFDEF has also 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
diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt
index 2f62be9a..3de938d7 100644
--- a/dev/doc/changes.txt
+++ b/dev/doc/changes.txt
@@ -1,5 +1,281 @@
 =========================================
-= CHANGES BETWEEN COQ V8.4 AND CQQ V8.5 =
+= CHANGES BETWEEN COQ V8.5 AND COQ V8.6 =
+=========================================
+
+** Parsing **
+
+Pcoq.parsable now takes an extra optional filename argument so as to
+bind locations to a file name when relevant.
+
+** Files **
+
+To avoid clashes with OCaml's compiler libs, the following files were renamed:
+kernel/closure.ml{,i} -> kernel/cClosure.ml{,i}
+lib/errors.ml{,i} -> lib/cErrors.ml{,i}
+toplevel/cerror.ml{,i} -> toplevel/explainErr.mli{,i}
+
+All IDE-specific files, including the XML protocol have been moved to ide/
+
+** Reduction functions **
+
+In closure.ml, we introduced the more precise reduction flags fMATCH, fFIX,
+fCOFIX.
+
+We renamed the following functions:
+
+Closure.betadeltaiota -> Closure.all
+Closure.betadeltaiotanolet -> Closure.allnolet
+Reductionops.beta -> Closure.beta
+Reductionops.zeta -> Closure.zeta
+Reductionops.betaiota -> Closure.betaiota
+Reductionops.betaiotazeta -> Closure.betaiotazeta
+Reductionops.delta -> Closure.delta
+Reductionops.betalet -> Closure.betazeta
+Reductionops.betadelta -> Closure.betadeltazeta
+Reductionops.betadeltaiota -> Closure.all
+Reductionops.betadeltaiotanolet -> Closure.allnolet
+Closure.no_red -> Closure.nored
+Reductionops.nored -> Closure.nored
+Reductionops.nf_betadeltaiota -> Reductionops.nf_all
+Reductionops.whd_betadelta -> Reductionops.whd_betadeltazeta
+Reductionops.whd_betadeltaiota -> Reductionops.whd_all
+Reductionops.whd_betadeltaiota_nolet -> Reductionops.whd_allnolet
+Reductionops.whd_betadelta_stack -> Reductionops.whd_betadeltazeta_stack
+Reductionops.whd_betadeltaiota_stack -> Reductionops.whd_all_stack
+Reductionops.whd_betadeltaiota_nolet_stack -> Reductionops.whd_allnolet_stack
+Reductionops.whd_betadelta_state -> Reductionops.whd_betadeltazeta_state
+Reductionops.whd_betadeltaiota_state -> Reductionops.whd_all_state
+Reductionops.whd_betadeltaiota_nolet_state -> Reductionops.whd_allnolet_state
+Reductionops.whd_eta -> Reductionops.shrink_eta
+Tacmach.pf_whd_betadeltaiota -> Tacmach.pf_whd_all
+Tacmach.New.pf_whd_betadeltaiota -> Tacmach.New.pf_whd_all
+
+And removed the following ones:
+
+Reductionops.whd_betaetalet
+Reductionops.whd_betaetalet_stack
+Reductionops.whd_betaetalet_state
+Reductionops.whd_betadeltaeta_stack
+Reductionops.whd_betadeltaeta_state
+Reductionops.whd_betadeltaeta
+Reductionops.whd_betadeltaiotaeta_stack
+Reductionops.whd_betadeltaiotaeta_state
+Reductionops.whd_betadeltaiotaeta
+
+In intf/genredexpr.mli, fIota was replaced by FMatch, FFix and
+FCofix. Similarly, rIota was replaced by rMatch, rFix and rCofix.
+
+** Notation_ops **
+
+Use Glob_ops.glob_constr_eq instead of Notation_ops.eq_glob_constr.
+
+** Logging and Pretty Printing: **
+
+* Printing functions have been removed from `Pp.mli`, which is now a
+  purely pretty-printing interface. Functions affected are:
+
+```` ocaml
+val pp          : std_ppcmds -> unit
+val ppnl        : std_ppcmds -> unit
+val pperr       : std_ppcmds -> unit
+val pperrnl     : std_ppcmds -> unit
+val pperr_flush : unit -> unit
+val pp_flush    : unit -> unit
+val flush_all   : unit -> unit
+val msg         : std_ppcmds -> unit
+val msgnl       : std_ppcmds -> unit
+val msgerr      : std_ppcmds -> unit
+val msgerrnl    : std_ppcmds -> unit
+val message     : string -> unit
+````
+
+  which are no more available. Users of `Pp.pp msg` should now use the
+  proper `Feedback.msg_*` function. Clients also have no control over
+  flushing, the back end takes care of it.
+
+  Also, the `msg_*` functions now take an optional `?loc` parameter
+  for relaying location to the client.
+
+* Feedback related functions and definitions have been moved to the
+  `Feedback` module. `message_level` has been renamed to
+  level. Functions moved from Pp to Feedback are:
+
+```` ocaml
+val set_logger      : logger -> unit
+val std_logger      : logger
+val emacs_logger    : logger
+val feedback_logger : logger
+````
+
+* Changes in the Feedback format/Protocol.
+
+- The `Message` feedback type now carries an optional location, the main
+  payload is encoded using the richpp document format.
+
+- The `ErrorMsg` feedback type is thus unified now with `Message` at
+  level `Error`.
+
+* We now provide several loggers, `log_via_feedback` is removed in
+  favor of `set_logger feedback_logger`. Output functions are:
+
+```` ocaml
+val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b
+val msg_error   : ?loc:Loc.t -> Pp.std_ppcmds -> unit
+val msg_warning : ?loc:Loc.t -> Pp.std_ppcmds -> unit
+val msg_notice  : ?loc:Loc.t -> Pp.std_ppcmds -> unit
+val msg_info    : ?loc:Loc.t -> Pp.std_ppcmds -> unit
+val msg_debug   : ?loc:Loc.t -> Pp.std_ppcmds -> unit
+````
+
+  with the `msg_*` functions being just an alias for `logger $Level`.
+
+* The main feedback functions are:
+
+```` ocaml
+val set_feeder : (feedback -> unit) -> unit
+val feedback : ?id:edit_or_state_id -> ?route:route_id -> feedback_content -> unit
+val set_id_for_feedback : ?route:route_id -> edit_or_state_id -> unit
+````
+  Note that `feedback` doesn't take two parameters anymore. After
+  refactoring the following function has been removed:
+
+```` ocaml
+val get_id_for_feedback : unit -> edit_or_state_id * route_id
+````
+
+** Kernel API changes **
+
+- The interface of the Context module was changed.
+  Related types and functions were put in separate submodules.
+  The mapping from old identifiers to new identifiers is the following:
+
+    Context.named_declaration            --->  Context.Named.Declaration.t
+    Context.named_list_declaration       --->  Context.NamedList.Declaration.t
+    Context.rel_declaration              --->  Context.Rel.Declaration.t
+    Context.map_named_declaration        --->  Context.Named.Declaration.map_constr
+    Context.map_named_list_declaration   --->  Context.NamedList.Declaration.map
+    Context.map_rel_declaration          --->  Context.Rel.Declaration.map_constr
+    Context.fold_named_declaration       --->  Context.Named.Declaration.fold
+    Context.fold_rel_declaration         --->  Context.Rel.Declaration.fold
+    Context.exists_named_declaration     --->  Context.Named.Declaration.exists
+    Context.exists_rel_declaration       --->  Context.Rel.Declaration.exists
+    Context.for_all_named_declaration    --->  Context.Named.Declaration.for_all
+    Context.for_all_rel_declaration      --->  Context.Rel.Declaration.for_all
+    Context.eq_named_declaration         --->  Context.Named.Declaration.equal
+    Context.eq_rel_declaration           --->  Context.Rel.Declaration.equal
+    Context.named_context                --->  Context.Named.t
+    Context.named_list_context           --->  Context.NamedList.t
+    Context.rel_context                  --->  Context.Rel.t
+    Context.empty_named_context          --->  Context.Named.empty
+    Context.add_named_decl               --->  Context.Named.add
+    Context.vars_of_named_context        --->  Context.Named.to_vars
+    Context.lookup_named                 --->  Context.Named.lookup
+    Context.named_context_length         --->  Context.Named.length
+    Context.named_context_equal          --->  Context.Named.equal
+    Context.fold_named_context           --->  Context.Named.fold_outside
+    Context.fold_named_list_context      --->  Context.NamedList.fold
+    Context.fold_named_context_reverse   --->  Context.Named.fold_inside
+    Context.instance_from_named_context  --->  Context.Named.to_instance
+    Context.extended_rel_list            --->  Context.Rel.to_extended_list
+    Context.extended_rel_vect            --->  Context.Rel.to_extended_vect
+    Context.fold_rel_context             --->  Context.Rel.fold_outside
+    Context.fold_rel_context_reverse     --->  Context.Rel.fold_inside
+    Context.map_rel_context              --->  Context.Rel.map_constr
+    Context.map_named_context            --->  Context.Named.map_constr
+    Context.iter_rel_context             --->  Context.Rel.iter
+    Context.iter_named_context           --->  Context.Named.iter
+    Context.empty_rel_context            --->  Context.Rel.empty
+    Context.add_rel_decl                 --->  Context.Rel.add
+    Context.lookup_rel                   --->  Context.Rel.lookup
+    Context.rel_context_length           --->  Context.Rel.length
+    Context.rel_context_nhyps            --->  Context.Rel.nhyps
+    Context.rel_context_tags             --->  Context.Rel.to_tags
+
+- Originally, rel-context was represented as:
+
+    Context.rel_context = Names.Name.t * Constr.t option * Constr.t
+
+  Now it is represented as:
+
+    Context.Rel.Declaration.t = LocalAssum of Names.Name.t * Constr.t
+	                      | LocalDef of Names.Name.t * Constr.t * Constr.t
+ 
+- Originally, named-context was represented as:
+
+    Context.named_context = Names.Id.t * Constr.t option * Constr.t
+
+  Now it is represented as:
+
+    Context.Named.Declaration.t = LocalAssum of Names.Id.t * Constr.t
+	                        | LocalDef of Names.Id.t * Constr.t * Constr.t
+
+- The various EXTEND macros do not handle specially the Coq-defined entries
+  anymore. Instead, they just output a name that have to exist in the scope
+  of the ML code. The parsing rules (VERNAC) ARGUMENT EXTEND will look for
+  variables "$name" of type Gram.entry, while the parsing rules of
+  (VERNAC COMMAND | TACTIC) EXTEND, as well as the various TYPED AS clauses will
+  look for variables "wit_$name" of type Genarg.genarg_type. The small DSL
+  for constructing compound entries still works over this scheme. Note that in
+  the case of (VERNAC) ARGUMENT EXTEND, the name of the argument entry is bound
+  in the parsing rules, so beware of recursive calls.
+  
+  For example, to get "wit_constr" you must "open Constrarg" at the top of the file.
+
+- Evarutil was split in two parts. The new Evardefine file exposes functions
+define_evar_* mostly used internally in the unification engine.
+
+- The Refine module was move out of Proofview.
+
+    Proofview.Refine.* --->  Refine.*
+
+- A statically monotonous evarmap type was introduced in Sigma. Not all the API
+  has been converted, so that the user may want to use compatibility functions
+  Sigma.to_evar_map and Sigma.Unsafe.of_evar_map or Sigma.Unsafe.of_pair when
+  needed. Code can be straightforwardly adapted in the following way:
+
+  let (sigma, x1) = ... in
+  ...
+  let (sigma, xn) = ... in
+  (sigma, ans)
+
+  should be turned into:
+
+  open Sigma.Notations
+
+  let Sigma (x1, sigma, p1) = ... in
+  ...
+  let Sigma (xn, sigma, pn) = ... in
+  Sigma (ans, sigma, p1 +> ... +> pn)
+  
+  Examples of `Sigma.Unsafe.of_evar_map` include:
+  
+  Evarutil.new_evar env (Tacmach.project goal) ty   ----> Evarutil.new_evar env (Sigma.Unsafe.of_evar_map (Tacmach.project goal)) ty
+
+- The Proofview.Goal.*enter family of functions now takes a polymorphic
+  continuation given as a record as an argument.
+
+  Proofview.Goal.enter begin fun gl -> ... end
+
+  should be turned into
+
+  open Proofview.Notations
+
+  Proofview.Goal.enter { enter = begin fun gl -> ... end }
+  
+- `Tacexpr.TacDynamic(Loc.dummy_loc, Pretyping.constr_in c)`      ---> `Tacinterp.Value.of_constr c`
+- `Vernacexpr.HintsResolveEntry(priority, poly, hnf, path, atom)` ---> `Vernacexpr.HintsResolveEntry(Vernacexpr.({hint_priority = priority; hint_pattern = None}), poly, hnf, path, atom)`
+- `Pretyping.Termops.mem_named_context`                           ---> `Engine.Termops.mem_named_context_val`
+  (`Global.named_context`                                         ---> `Global.named_context_val`)
+  (`Context.Named.lookup`                                         ---> `Environ.lookup_named_val`)
+
+** Search API **
+
+The main search functions now take a function iterating over the
+results. This allows for clients to use streaming or more economic
+printing.
+
+=========================================
+= CHANGES BETWEEN COQ V8.4 AND COQ V8.5 =
 =========================================
 
 ** Refactoring : more mli interfaces and simpler grammar.cma **
diff --git a/dev/doc/coq-src-description.txt b/dev/doc/coq-src-description.txt
index fe896d31..00e7f5c5 100644
--- a/dev/doc/coq-src-description.txt
+++ b/dev/doc/coq-src-description.txt
@@ -19,13 +19,6 @@ 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
 ------------------
 
diff --git a/dev/doc/drop.txt b/dev/doc/drop.txt
new file mode 100644
index 00000000..3a584741
--- /dev/null
+++ b/dev/doc/drop.txt
@@ -0,0 +1,44 @@
+When you start byte-compiled Coq toplevel:
+
+  rlwrap bin/coqtop.byte
+
+then if you type:
+
+  Drop.
+
+you will decend from Coq toplevel down to Ocaml toplevel.
+So if you want to learn:
+- the current values of some global variables you are interested in
+- or see what happens when you invoke certain functions
+this is the place where you can do that.
+
+When you try to print values belonging to abstract data types:
+
+  # let sigma, env = Lemmas.get_current_context ();;
+  
+  val sigma : Evd.evar_map = <abstr>
+  val env : Environ.env = <abstr>
+
+  # Typeops.infer env (snd (Pretyping.understand_tcc env sigma (Constrintern.intern_constr env (Pcoq.parse_string Pcoq.Constr.lconstr "plus"))));;
+
+  - : Environ.unsafe_judgment = {Environ.uj_val = <abstr>; uj_type = <abstr>}
+
+the printed values are not very helpful.
+
+One way how to deal with that is to load the corresponding printers:
+
+  # #use "dev/include";;
+
+Consequently, the result of:
+
+  # Typeops.infer env (snd (Pretyping.understand_tcc env sigma (Constrintern.intern_constr env (Pcoq.parse_string Pcoq.Constr.lconstr "plus"))));;
+
+will be printed as:
+
+  - : Environ.unsafe_judgment = Nat.add : nat -> nat -> nat
+
+which makes more sense.
+
+To be able to understand the meaning of the data types,
+sometimes the best option is to turn those data types from abstract to concrete
+and look at them without any kind of pretty printing.
diff --git a/dev/doc/notes-on-conversion b/dev/doc/notes-on-conversion
index 6274275c..a81f170c 100644
--- a/dev/doc/notes-on-conversion
+++ b/dev/doc/notes-on-conversion
@@ -21,7 +21,7 @@ Notation OMEGA := (ack 4 4).
 
 Definition f (x:nat) := x.
 
-(* Evaluation in tactics can somehow be controled *)
+(* Evaluation in tactics can somehow be controlled *)
 Lemma l1 : OMEGA = OMEGA.
 reflexivity.  (* succeed: identity *)
 Qed.          (* succeed: identity *)
diff --git a/dev/doc/ocamlbuild.txt b/dev/doc/ocamlbuild.txt
new file mode 100644
index 00000000..efedbc50
--- /dev/null
+++ b/dev/doc/ocamlbuild.txt
@@ -0,0 +1,30 @@
+Ocamlbuild & Coq
+----------------
+
+A quick note in case someone else gets interested someday in compiling
+Coq via ocamlbuild : such an experimental build system has existed
+in the past (more or less maintained from 2009 to 2013), in addition
+to the official build system via gnu make. But this build via
+ocamlbuild has been severly broken since early 2014 (and don't work
+in 8.5, for instance). This experiment has attracted very limited
+interest from other developers over the years, and has been quite
+cumbersome to maintain, so it is now officially discontinued.
+If you want to have a look at the files of this build system
+(especially myocamlbuild.ml), you can fetch :
+ - my last effort at repairing this build system (up to coqtop.native) :
+   https://github.com/letouzey/coq-wip/tree/ocamlbuild-partial-repair
+ - coq official v8.5 branch (recent but broken)
+ - coq v8.4 branch(less up-to-date, but works).
+
+For the record, the three main drawbacks of this experiments were:
+ - recurrent issues with circularities reported by ocamlbuild
+   (even though make was happy) during the evolution of Coq sources
+ - no proper support of parallel build
+ - quite slow re-traversal of already built things
+See the two corresponding bug reports on Mantis, or
+https://github.com/ocaml/ocamlbuild/issues/52
+
+As an interesting feature, I successfully used this to cross-compile
+Coq 8.4 from linux to win32 via mingw.
+
+Pierre Letouzey, june 2016
diff --git a/dev/doc/profiling.txt b/dev/doc/profiling.txt
new file mode 100644
index 00000000..9d2ebf0d
--- /dev/null
+++ b/dev/doc/profiling.txt
@@ -0,0 +1,76 @@
+# How to profile Coq?
+
+I (Pierre-Marie Pédrot) mainly use two OCaml branches to profile Coq, whether I
+want to profile time or memory consumption. AFAIK, this only works for Linux.
+
+## Time
+
+In Coq source folder:
+
+opam switch 4.02.1+fp
+./configure -local -debug
+make
+perf record -g bin/coqtop -compile file.v
+perf report -g fractal,callee --no-children
+
+To profile only part of a file, first load it using
+
+bin/coqtop -l file.v
+
+and plug into the process
+
+perf record -g -p PID
+
+## Memory
+
+You first need a few commits atop trunk for this to work.
+
+git remote add ppedrot https://github.com/ppedrot/coq.git
+git fetch ppedrot
+git checkout ppedrot/allocation-profiling
+git rebase master
+
+Then:
+
+opam switch 4.00.1+alloc-profiling
+./configure -local -debug
+make
+
+Note that linking the coqtop binary takes quite an amount of time with this
+branch, so do not worry too much. There are more recent branches of
+alloc-profiling on mshinwell's repo which can be found at:
+
+https://github.com/mshinwell/opam-repo-dev
+
+### For memory dump:
+
+CAMLRUNPARAM=T,mj bin/coqtop -compile file.v
+
+In another terminal:
+
+pkill -SIGUSR1 $COQTOPPID
+...
+pkill -SIGUSR1 $COQTOPPID
+dev/decode-major-heap.sh heap.$COQTOPPID.$N bin/coqtop
+
+where $COQTOPPID is coqtop pid and $N the index of the call to pkill.
+
+First column is the memory taken by the objects (in words), second one is the
+number of objects and third is the place where the objects where allocated.
+
+### For complete memory graph:
+
+CAMLRUNPARAM=T,gr bin/coqtop -compile file.v
+
+In another terminal:
+
+pkill -SIGUSR1 $COQTOPPID
+...
+pkill -SIGUSR1 $COQTOPPID
+ocaml dev/decodegraph.ml edge.$COQTOPPID.$N bin/coqtop > memory.dot
+dot -Tpdf -o memory.pdf memory.dot
+
+where $COQTOPPID is coqtop pid and $N the index of the call to pkill.
+
+The pdf produced by the last command gives a compact graphical representation of
+the various objects allocated.
diff --git a/dev/doc/setup.txt b/dev/doc/setup.txt
new file mode 100644
index 00000000..1b016a4e
--- /dev/null
+++ b/dev/doc/setup.txt
@@ -0,0 +1,289 @@
+This document provides detailed guidance on how to:
+- compile Coq
+- take advantage of Merlin in Emacs
+- enable auto-completion for Ocaml source-code
+- use ocamldebug in Emacs for debugging coqtop
+The instructions were tested with Debian 8.3 (Jessie).
+
+The procedure is somewhat tedious, but the final results are (still) worth the effort.
+
+How to compile Coq
+------------------
+
+Getting build dependencies:
+
+  sudo apt-get install make opam git mercurial darcs
+  opam init --comp 4.02.3
+  # Then follow the advice displayed at the end as how to update your ~/.bashrc and ~/.ocamlinit files.
+  
+  source ~/.bashrc
+  
+  # needed if you want to build "coqtop" target
+  opam install camlp5
+  
+  # needed if you want to build "coqide" target
+  sudo apt-get install liblablgtksourceview2-ocaml-dev libgtk2.0-dev libgtksourceview2.0-dev
+  opam install lablgtk
+  
+  # needed if you want to build "doc" target
+  sudo apt-get install texlive-latex-recommended texlive-fonts-extra texlive-math-extra \
+                       hevea texlive-latex-extra latex-xcolor
+
+Cloning Coq:
+
+  # Go to the directory where you want to clone Coq's source-code. E.g.:
+  cd ~/git
+
+  git clone https://github.com/coq/coq.git
+
+Building coqtop:
+
+  cd ~/git/coq
+  git checkout trunk
+  make distclean
+  ./configure -annotate -with-doc no -local -debug -usecamlp5
+  make clean
+  make -j4 coqide printers
+
+The "-annotate" option is essential when one wants to use Merlin.
+
+The "-local" option is useful if one wants to run the coqtop and coqide binaries without running make install
+
+The "-debug" option is essential if one wants to use ocamldebug with the coqtop binary.
+
+Then check if
+- bin/coqtop
+- bin/coqide
+behave as expected.
+
+
+A note about rlwrap
+-------------------
+
+Running "coqtop" under "rlwrap" is possible, but there is a catch. If you try:
+
+  cd ~/git/coq
+  rlwrap bin/coqtop
+
+you will get an error:
+
+  rlwrap: error: Couldn't read completions from /usr/share/rlwrap/completions/coqtop: No such file or directory
+
+This is a known issue:
+
+  https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=779692
+
+It was fixed upstream in version 0.42, and in a Debian package that, at the time of writing, is not part of Debian stable/testing/sid archives but only of Debian experimental.
+
+  https://packages.debian.org/experimental/rlwrap
+
+The quick solution is to grab it from there, since it installs fine on Debian stable (jessie).
+
+  cd /tmp
+  wget  http://ftp.us.debian.org/debian/pool/main/r/rlwrap/rlwrap_0.42-1_amd64.deb
+  sudo dpkg -i rlwrap_0.42-1_amd64.deb
+
+After that, "rlwrap" works fine with "coqtop".
+
+
+How to install and configure Merlin (for Emacs)
+-----------------------------------------------
+
+  sudo apt-get install emacs
+
+  opam install tuareg
+  # Follow the advice displayed at the end as how to update your ~/.emacs file.
+  
+  opam install merlin
+  # Follow the advice displayed at the end as how to update your ~/.emacs file.
+
+Then add this:
+
+  (push "~/.opam/4.02.3/share/emacs/site-lisp" load-path)     ; directory containing merlin.el
+  (setq merlin-command "~/.opam/4.02.3/bin/ocamlmerlin")      ; needed only if ocamlmerlin not already in your PATH
+  (autoload 'merlin-mode "merlin" "Merlin mode" t)
+  (add-hook 'tuareg-mode-hook 'merlin-mode)
+  (add-hook 'caml-mode-hook 'merlin-mode)
+  (load "~/.opam/4.02.3/share/emacs/site-lisp/tuareg-site-file")
+  
+  ;; Do not use TABs. These confuse Merlin.
+  (setq-default indent-tabs-mode nil)
+
+to your ~/.emacs file.
+
+Further Emacs configuration when we start it for the first time.
+
+Try to open some *.ml file in Emacs, e.g.:
+
+  cd ~/git/coq
+  emacs toplevel/coqtop.ml &
+
+Emacs display the following strange message:
+
+  The local variables list in ~/git/coq
+  contains values that may be safe (*).
+
+  Do you want to apply it?
+
+Just press "!", i.e. "apply the local variable list, and permanently mark these values (\*) as safe."
+
+Emacs then shows two windows:
+- one window that shows the contents of the "toplevel/coqtop.ml" file
+- and the other window that shows greetings for new Emacs users.
+
+If you do not want to see the second window next time you start Emacs, just check "Never show it again" and click on "Dismiss this startup screen."
+
+The default key-bindings are described here:
+
+  https://github.com/the-lambda-church/merlin/wiki/emacs-from-scratch
+
+If you want, you can customize them by replacing the following lines:
+
+  (define-key merlin-map (kbd "C-c C-x") 'merlin-error-next)
+  (define-key merlin-map (kbd "C-c C-l") 'merlin-locate)
+  (define-key merlin-map (kbd "C-c &") 'merlin-pop-stack)
+  (define-key merlin-map (kbd "C-c C-t") 'merlin-type-enclosing)
+
+in the file "~/.opam/4.02.3/share/emacs/site-lisp/merlin.el" with what you want.
+In the text below we assume that you changed the origin key-bindings in the following way:
+
+  (define-key merlin-map (kbd "C-n") 'merlin-error-next)
+  (define-key merlin-map (kbd "C-l") 'merlin-locate)
+  (define-key merlin-map (kbd "C-b") 'merlin-pop-stack)
+  (define-key merlin-map (kbd "C-t") 'merlin-type-enclosing)
+
+Now, when you press <Ctrl+L>, Merlin will show the definition of the symbol in a separate window.
+If you prefer to jump to the definition within the same window, do this:
+
+  <Alt+X> customize-group <ENTER> merlin <ENTER>
+
+    Merlin Locate In New Window
+
+      Value Menu
+
+        Never Open In New Window
+
+      State
+
+        Set For Future Sessions
+
+Testing (Merlin):
+
+  cd ~/git/coq
+  emacs toplevel/coqtop.ml &
+
+Go to the end of the file where you will see the "start" function.
+
+Go to a line where "init_toplevel" function is called.
+
+If you want to jump to the position where that function or datatype under the cursor is defined, press <Ctrl+L>.
+
+If you want to jump back, type: <Ctrl+B>
+
+If you want to learn the type of the value at current cursor's position, type: <Ctrl+T>
+
+
+Enabling auto-completion in emacs
+---------------------------------
+
+In Emacs, type: <Alt+M> list-packages <ENTER>
+
+In the list that is displayed, click on "company".
+
+A new window appears where just click on "Install" and then answer "Yes".
+
+These lines:
+
+  (package-initialize)
+  (require 'company)
+  ; Make company aware of merlin
+  (add-to-list 'company-backends 'merlin-company-backend)
+  ; Enable company on merlin managed buffers
+  (add-hook 'merlin-mode-hook 'company-mode)
+  (global-set-key [C-tab] 'company-complete)
+
+then need to be added to your "~/.emacs" file.
+
+Next time when you start emacs and partially type some identifier,
+emacs will offer the corresponding completions.
+Auto-completion can also be manually invoked by typing <Ctrl+TAB>.
+Description of various other shortcuts is here.
+
+  http://company-mode.github.io/
+
+
+Getting along with ocamldebug
+-----------------------------
+
+The default ocamldebug key-bindings are described here.
+
+  http://caml.inria.fr/pub/docs/manual-ocaml/debugger.html#sec369
+
+If you want, you can customize them by putting the following commands:
+
+  (global-set-key (kbd "<f5>") 'ocamldebug-break)
+  (global-set-key (kbd "<f6>") 'ocamldebug-run)
+  (global-set-key (kbd "<f7>") 'ocamldebug-next)
+  (global-set-key (kbd "<f8>") 'ocamldebug-step)
+  (global-set-key (kbd "<f9>") 'ocamldebug-finish)
+  (global-set-key (kbd "<f10>") 'ocamldebug-print)
+  (global-set-key (kbd "<f12>") 'camldebug)
+
+to your "~/.emacs" file.
+
+Let us try whether ocamldebug in Emacs works for us.
+(If necessary, re-)compile coqtop:
+
+  cd ~/git/coq
+  make -j4 coqide printers
+
+open Emacs:
+
+  emacs toplevel/coqtop.ml &
+
+and type:
+
+  <F12> ../bin/coqtop.byte <ENTER> ../dev/ocamldebug-coq <ENTER>
+
+As a result, a new window is open at the bottom where you should see:
+
+  (ocd)
+
+i.e. an ocamldebug shell.
+
+  1. Switch to the window that contains the "coqtop.ml" file.
+  2. Go to the end of the file.
+  3. Find the definition of the "start" function.
+  4. Go to the "let" keyword that is at the beginning of the first line.
+  5. By pressing <F5> you set a breakpoint to the cursor's position.
+  6. By pressing <F6> you start the bin/coqtop process.
+  7. Then you can:
+     - step over function calls: <F7>
+     - step into function calls: <F8>
+     - or finish execution of the current function until it returns: <F9>.
+
+Other ocamldebug commands, can be typed to the window that holds the ocamldebug shell.
+
+The points at which the execution of Ocaml program can stop are defined here:
+
+  http://caml.inria.fr/pub/docs/manual-ocaml/debugger.html#sec350
+
+
+Installing printers to ocamldebug
+---------------------------------
+
+There is a pretty comprehensive set of printers defined for many common data types.
+You can load them by switching to the window holding the "ocamldebug" shell and typing:
+
+  (ocd) source "../dev/db"
+
+
+Some of the functions were you might want to set a breakpoint and see what happens next
+---------------------------------------------------------------------------------------
+
+- Coqtop.start : This function is called by the code produced by "coqmktop".
+- Coqtop.parse_args : This function is responsible for parsing command-line arguments.
+- Coqloop.loop : This function implements the read-eval-print loop.
+- Vernacentries.interp : This function is called to execute the Vernacular command user have typed.\
+                         It dispatches the control to specific functions handling different Vernacular command.
+- Vernacentries.vernac_check_may_eval : This function handles the "Check ..." command.
diff --git a/dev/include b/dev/include
index b2eb280d..d82fb74f 100644
--- a/dev/include
+++ b/dev/include
@@ -25,7 +25,7 @@
 #cd ".";;
 #use "base_include";;
 
-#install_printer  (* pp_stdcmds *) pppp;;
+#install_printer  (* pp_stdcmds *) pp;;
 
 #install_printer  (* pattern *) pppattern;;
 #install_printer  (* glob_constr *) ppglob_constr;;
diff --git a/dev/make-installer-win32.sh b/dev/make-installer-win32.sh
deleted file mode 100755
index d405e66c..00000000
--- a/dev/make-installer-win32.sh
+++ /dev/null
@@ -1,22 +0,0 @@
-#!/bin/sh
-
-set -e
-
-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 -debug -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-installer-win64.sh b/dev/make-installer-win64.sh
deleted file mode 100755
index 2f765c1a..00000000
--- a/dev/make-installer-win64.sh
+++ /dev/null
@@ -1,28 +0,0 @@
-#!/bin/sh
-
-set -e
-
-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 -debug -prefix ./ -with-doc no
-make -j2 coqide
-mkdir -p bin32
-cp bin/* bin32/
-make clean
-make archclean
-( . ${BASE}_64/environ && ./configure -debug -prefix ./ -with-doc no && make -j2 && make ide/coqidetop.cmxs )
-cp bin32/coqide* bin/
-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
deleted file mode 100755
index 0112324d..00000000
--- a/dev/make-sdk-win32.sh
+++ /dev/null
@@ -1,370 +0,0 @@
-#!/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/coq.nsi b/dev/nsis/coq.nsi
index 67649051..80da8451 100755
--- a/dev/nsis/coq.nsi
+++ b/dev/nsis/coq.nsi
@@ -13,7 +13,7 @@ SetCompressor lzma
 
 !define MY_PRODUCT "Coq" ;Define your own software name here
 !define COQ_SRC_PATH "..\.."
-!define OUTFILE "coq-installer-${VERSION}.exe"
+!define OUTFILE "coq-installer-${VERSION}-${ARCH}.exe"
 
 !include "MUI2.nsh"
 !include "FileAssociation.nsh"
@@ -83,6 +83,7 @@ FunctionEnd
 Section "Coq" Sec1
 
   SetOutPath "$INSTDIR\"
+  File ${COQ_SRC_PATH}\LICENSE
 
   SetOutPath "$INSTDIR\bin"
   File ${COQ_SRC_PATH}\bin\*.exe
diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run
index d4ab22ce..f9310e07 100644
--- a/dev/ocamldebug-coq.run
+++ b/dev/ocamldebug-coq.run
@@ -17,9 +17,10 @@ exec $OCAMLDEBUG \
 	-I $COQTOP \
 	-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/library -I $COQTOP/engine \
+	-I $COQTOP/pretyping -I $COQTOP/parsing \
         -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics -I $COQTOP/stm \
-	-I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config \
+	-I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config -I $COQTOP/ltac \
         -I $COQTOP/plugins/cc         -I $COQTOP/plugins/dp \
         -I $COQTOP/plugins/extraction -I $COQTOP/plugins/field \
         -I $COQTOP/plugins/firstorder -I $COQTOP/plugins/fourier \
diff --git a/dev/ocamldoc/fix-ocamldoc-utf8 b/dev/ocamldoc/fix-ocamldoc-utf8
new file mode 100755
index 00000000..fe2e0c11
--- /dev/null
+++ b/dev/ocamldoc/fix-ocamldoc-utf8
@@ -0,0 +1,6 @@
+#!/bin/sh
+
+# This reverts automatic translation of latin1 accentuated letters by ocamldoc
+# Usage: fix-ocamldoc-utf8 file
+
+sed -i -e 's/\\`a/\d224/g' -e "s/\\\^a/\d226/g" -e "s/\\\'e/\d233/g" -e 's/\\`e/\d232/g' -e "s/\\\^e/\d234/g" -e 's/\\\"e/\d235/g' -e "s/\\\^o/\d244/g" -e 's/\\\"o/\d246/g' -e "s/\\\^i/\d238/g" -e 's/\\\"i/\d239/g' -e 's/\\`u/\d249/g' -e "s/\\\^u/\d251/g" -e "s/\\\c{c}/\d231/g" $1
diff --git a/dev/ocamldoc/header.tex b/dev/ocamldoc/header.tex
new file mode 100644
index 00000000..4091f814
--- /dev/null
+++ b/dev/ocamldoc/header.tex
@@ -0,0 +1,14 @@
+\documentclass[11pt]{article} 
+\usepackage[utf8x]{inputenc} 
+\usepackage[T1]{fontenc} 
+\usepackage{textcomp}
+\usepackage{tipa}
+\usepackage{textgreek}
+\usepackage{fullpage} 
+\usepackage{url} 
+\usepackage{ocamldoc}
+\title{Coq mlis documentation}
+\begin{document}
+\maketitle
+\tableofcontents
+\vspace{0.2cm}
diff --git a/dev/ocamlopt_shared_os5fix.sh b/dev/ocamlopt_shared_os5fix.sh
deleted file mode 100755
index f7d31ad8..00000000
--- a/dev/ocamlopt_shared_os5fix.sh
+++ /dev/null
@@ -1,29 +0,0 @@
-#/bin/sh
-
-### Temporary fix for production of .cmxs on MacOS 10.5
-
-OCAMLOPT=$1
-CMXS=$2
-
-DIR=`dirname $CMXS`
-BASE=`basename $CMXS .cmxs`
-CMXA=$DIR/$BASE.cmxa
-ARC=$DIR/$BASE.a
-# we assume that all object files are at the same place than the rest
-OBJS=`ar t $ARC | sed -e "s|^|$DIR/|" | grep -v SYMDEF`
-
-$OCAMLOPT -dstartup -linkall -shared -o $CMXS $CMXA
-# Fix1: add a dummy instruction before the caml generic functions
-# Fix2: make all caml generic functions private
-rm -f $CMXS $CMXS.startup.fixed.s
-cat $CMXS.startup.s | sed \
- -e "s/_caml_shared_startup__code_begin:/_caml_shared_startup__code_begin:	ret/" \
- -e "s/.globl	_caml_curry/.private_extern	_caml_curry/" \
- -e "s/.globl	_caml_apply/.private_extern	_caml_apply/" \
- -e "s/.globl	_caml_tuplify/.private_extern	_caml_tuplify/" \
- > $CMXS.startup.fixed.s
-# Recompile fixed startup code
-as -o $CMXS.startup.o $CMXS.startup.fixed.s
-# Build fixed .cmxs (assume all object files are at the same place)
-ld -bundle -flat_namespace -undefined warning -read_only_relocs suppress -o $CMXS $OBJS $CMXS.startup.o
-rm $CMXS.startup.o $CMXS.startup.s $CMXS.startup.fixed.s
\ No newline at end of file
diff --git a/dev/printers.mllib b/dev/printers.mllib
index ab7e9fc3..31654954 100644
--- a/dev/printers.mllib
+++ b/dev/printers.mllib
@@ -8,6 +8,7 @@ Hashcons
 CSet
 CMap
 Int
+Dyn
 HMap
 Option
 Store
@@ -18,26 +19,29 @@ Pp_control
 Loc
 CList
 CString
+Tok
 Compat
 Flags
 Control
 Loc
 Serialize
 Stateid
-Feedback
-Pp
-Segmenttree
-Unicodetable
-Unicode
 CObj
 CArray
 CStack
 Util
+Pp
 Ppstyle
-Errors
+Richpp
+Feedback
+Segmenttree
+Unicodetable
+Unicode
+CErrors
+CWarnings
 Bigint
-Dyn
 CUnix
+Minisys
 System
 Envars
 Aux_file
@@ -48,13 +52,14 @@ Rtree
 Heap
 Genarg
 Stateid
-Ephemeron
+CEphemeron
 Future
 RemoteCounter
 Monad
 
 Names
 Univ
+UGraph
 Esubst
 Uint31
 Sorts
@@ -81,7 +86,7 @@ Nativecode
 Nativelib
 Cbytegen
 Environ
-Closure
+CClosure
 Reduction
 Nativeconv
 Type_errors
@@ -116,17 +121,21 @@ Miscops
 Universes
 Termops
 Namegen
+UState
 Evd
+Sigma
 Glob_ops
 Redops
+Pretype_errors
+Evarutil
 Reductionops
 Inductiveops
 Arguments_renaming
 Nativenorm
 Retyping
 Cbv
-Pretype_errors
-Evarutil
+
+Evardefine
 Evarsolve
 Recordops
 Evarconv
@@ -137,6 +146,11 @@ Find_subterm
 Tacred
 Classops
 Typeclasses_errors
+Logic_monad
+Proofview_monad
+Proofview
+Ftactic
+Geninterp
 Typeclasses
 Detyping
 Indrec
@@ -150,8 +164,7 @@ Library
 States
 
 Genprint
-Tok
-Lexer
+CLexer
 Ppextend
 Pputils
 Ppannotation
@@ -171,21 +184,16 @@ Implicit_quantifiers
 Constrintern
 Modintern
 Constrextern
-Proof_type
 Goal
 Miscprint
 Logic
 Refiner
 Clenv
 Evar_refiner
-Proof_errors
-Logic_monad
-Proofview_monad
-Proofview
+Refine
 Proof
 Proof_global
 Pfedit
-Tactic_debug
 Decl_mode
 Ppconstr
 Pcoq
@@ -195,13 +203,12 @@ Ppdecl_proof
 Egramml
 Egramcoq
 Tacsubst
-Tacenv
 Trie
 Dn
 Btermdn
 Hints
 Himsg
-Cerrors
+ExplainErr
 Locality
 Assumptions
 Vernacinterp
diff --git a/dev/tools/anomaly-traces-parser.el b/dev/tools/anomaly-traces-parser.el
new file mode 100644
index 00000000..68f54266
--- /dev/null
+++ b/dev/tools/anomaly-traces-parser.el
@@ -0,0 +1,28 @@
+;; This Elisp snippet adds a regexp parser for the format of Anomaly
+;; backtraces (coqc -bt ...), to the error parser of the Compilation
+;; mode (C-c C-c: "Compile command: ..."). Once the
+;; coq-change-error-alist-for-backtraces function has run, file
+;; locations in traces are recognized and can be jumped from easily
+;; from the *compilation* buffer.
+
+;; You can just copy everything below to your .emacs and this will be
+;; enabled from any compilation command launched from an OCaml file.
+
+(defun coq-change-error-alist-for-backtraces ()
+  "Hook to change the compilation-error-regexp-alist variable, to
+   search the coq backtraces for error locations"
+  (interactive)
+  (add-to-list
+   'compilation-error-regexp-alist-alist
+   '(coq-backtrace
+     "^ *\\(?:raise\\|frame\\) @ file \\(\"?\\)\\([^,\" \n\t<>]+\\)\\1,\
+      lines? \\([0-9]+\\)-?\\([0-9]+\\)?\\(?:$\\|,\
+      \\(?: characters? \\([0-9]+\\)-?\\([0-9]+\\)?:?\\)?\\)"
+     2 (3 . 4) (5 . 6)))
+  (add-to-list 'compilation-error-regexp-alist 'coq-backtrace))
+
+;; this Anomaly parser should be available when one is hacking
+;; on the *OCaml* code of Coq (adding bugs), so we enable it
+;; through the OCaml mode hooks.
+(add-hook 'caml-mode-hook 'coq-change-error-alist-for-backtraces)
+(add-hook 'tuareg-mode-hook 'coq-change-error-alist-for-backtraces)
diff --git a/dev/top_printers.ml b/dev/top_printers.ml
index 6e5b048c..a3d5cf5c 100644
--- a/dev/top_printers.ml
+++ b/dev/top_printers.ml
@@ -29,7 +29,7 @@ let _ = set_bool_option_value ["Printing";"Matching"] false
 let _ = Detyping.set_detype_anonymous (fun _ _ -> raise Not_found)
 
 (* std_ppcmds *)
-let pppp x = pp x
+let pp   x = Pp.pp_with !Pp_control.std_ft x
 
 (** Future printer *)
 
@@ -40,10 +40,10 @@ let ppid id = pp (pr_id id)
 let pplab l = pp (pr_lab l)
 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 ppmp mp = pp(str (ModPath.debug_to_string 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 ppkn kn = pp(str (KerName.to_string 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)
@@ -79,7 +79,7 @@ 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 ppfconstr c = ppconstr (CClosure.term_of_fconstr c)
 
 let ppbigint n = pp (str (Bigint.to_string n));;
 
@@ -215,13 +215,12 @@ 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 ppuniverses u = pp (UGraph.pr_universes Level.pr u)
 let ppnamedcontextval e =
   pp (pr_named_context (Global.env ()) Evd.empty (named_context_of_val e))
 
@@ -315,7 +314,7 @@ let constr_display csr =
     | Anonymous -> "Anonymous"
 
   in
-  Pp.pp (str (term_display csr) ++fnl ()); Pp.pp_flush ()
+  pp (str (term_display csr) ++fnl ())
 
 open Format;;
 
@@ -456,7 +455,7 @@ let print_pure_constr csr =
 	print_string (Printexc.to_string e);print_flush ();
 	raise e
 
-let ppfconstr c = ppconstr (Closure.term_of_fconstr c)
+let ppfconstr c = ppconstr (CClosure.term_of_fconstr c)
 
 let pploc x = let (l,r) = Loc.unloc x in
   print_string"(";print_int l;print_string",";print_int r;print_string")"
@@ -467,16 +466,19 @@ 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 ->
+  let Geninterp.Val.Dyn (tag, _) = arg in
+  let tpe = Geninterp.Val.pr tag in
+  (** FIXME *)
+(*   try *)
+(*     let data = Pptactic.pr_top_generic (Global.env ()) arg in *)
+(*     str "<genarg:" ++ tpe ++ str " := [ " ++ data ++ str " ] >" *)
+(*   with _any -> *)
     str "<genarg:" ++ tpe ++ str ">"
 
 let ppgenarginfo arg = pp (prgenarginfo arg)
 
+let ppgenargargt arg = pp (str (Genarg.ArgT.repr arg))
+
 let ppist ist =
   let pr id arg = prgenarginfo arg in
   pp (pridmap pr ist.Geninterp.lfun)
@@ -485,9 +487,7 @@ let ppist ist =
 (* Vernac-level debugging commands                                    *)
 
 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
+  let (evmap,sign) = Pfedit.get_current_context () in
   f (fst (Constrintern.interp_constr sign evmap c))(*FIXME*)
 
 (* We expand the result of preprocessing to be independent of camlp4
@@ -509,35 +509,33 @@ let _ =
   try
     Vernacinterp.vinterp_add false ("PrintConstr", 0)
       (function
-         [c] when genarg_tag c = ConstrArgType && true ->
+         [c] when genarg_tag c = unquote (topwit wit_constr) && true ->
            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)
+    e -> pp (CErrors.print e)
 let _ =
   extend_vernac_command_grammar ("PrintConstr", 0) None
     [GramTerminal "PrintConstr";
       GramNonTerminal
-        (Loc.ghost,ConstrArgType,Aentry ("constr","constr"),
-	 Some (Names.Id.of_string "c"))]
+        (Loc.ghost,rawwit wit_constr,Extend.Aentry Pcoq.Constr.constr)]
 
 let _ =
   try
     Vernacinterp.vinterp_add false ("PrintPureConstr", 0)
       (function
-         [c] when genarg_tag c = ConstrArgType && true ->
+         [c] when genarg_tag c = unquote (topwit wit_constr) && true ->
            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)
+    e -> pp (CErrors.print e)
 let _ =
   extend_vernac_command_grammar ("PrintPureConstr", 0) None
     [GramTerminal "PrintPureConstr";
       GramNonTerminal
-        (Loc.ghost,ConstrArgType,Aentry ("constr","constr"),
-	 Some (Names.Id.of_string "c"))]
+        (Loc.ghost,rawwit wit_constr,Extend.Aentry Pcoq.Constr.constr)]
 
 (* Setting printer of unbound global reference *)
 open Names
diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml
index 1c501df8..afa94a63 100644
--- a/dev/vm_printers.ml
+++ b/dev/vm_printers.ml
@@ -79,7 +79,7 @@ and ppwhd whd =
   | Vatom_stk(a,s) ->
       open_hbox();ppatom a;close_box();
       print_string"@";ppstack s
-  | Vuniv_level lvl -> Pp.pp (Univ.Level.pr lvl)
+  | Vuniv_level lvl -> Feedback.msg_notice (Univ.Level.pr lvl)
 
 and ppvblock b =
   open_hbox();
diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template
index d6b1af79..9216c81f 100644
--- a/doc/stdlib/index-list.html.template
+++ b/doc/stdlib/index-list.html.template
@@ -21,6 +21,7 @@ through the <tt>Require Import</tt> command.</p>
     theories/Init/Peano.v
     theories/Init/Specif.v
     theories/Init/Tactics.v
+    theories/Init/Tauto.v
     theories/Init/Wf.v
     (theories/Init/Prelude.v)
   </dd>
@@ -59,6 +60,7 @@ through the <tt>Require Import</tt> command.</p>
     theories/Logic/WeakFan.v
     theories/Logic/WKL.v
     theories/Logic/FinFun.v
+    theories/Logic/PropFacts.v
   </dd>
 
   <dt> <b>Structures</b>:
@@ -202,6 +204,7 @@ through the <tt>Require Import</tt> command.</p>
     (theories/QArith/QArith.v)
     theories/QArith/Qreals.v
     theories/QArith/Qcanon.v
+    theories/QArith/Qcabs.v
     theories/QArith/Qround.v
     theories/QArith/QOrderedType.v
     theories/QArith/Qminmax.v
@@ -613,5 +616,6 @@ through the <tt>Require Import</tt> command.</p>
     theories/Compat/AdmitAxiom.v
     theories/Compat/Coq84.v
     theories/Compat/Coq85.v
+    theories/Compat/Coq86.v
   </dd>
 </dl>
diff --git a/engine/engine.mllib b/engine/engine.mllib
new file mode 100644
index 00000000..9ce5af81
--- /dev/null
+++ b/engine/engine.mllib
@@ -0,0 +1,11 @@
+Logic_monad
+Termops
+Namegen
+UState
+Evd
+Sigma
+Proofview_monad
+Evarutil
+Proofview
+Ftactic
+Geninterp
diff --git a/pretyping/evarutil.ml b/engine/evarutil.ml
index e23e5a53..df170c8d 100644
--- a/pretyping/evarutil.ml
+++ b/engine/evarutil.ml
@@ -6,20 +6,25 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
-open Pp
 open Names
 open Term
 open Vars
-open Context
 open Termops
 open Namegen
 open Pre_env
 open Environ
 open Evd
-open Reductionops
-open Pretype_errors
+open Sigma.Notations
+
+let safe_evar_info sigma evk =
+  try Some (Evd.find sigma evk)
+  with Not_found -> None
+
+let safe_evar_value sigma ev =
+  try Some (Evd.existential_value sigma ev)
+  with NotInstantiatedEvar | Not_found -> None
 
 (** Combinators *)
 
@@ -42,7 +47,7 @@ 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
+  Sigma.fresh_global (Global.env()) evd x
 
 (****************************************************)
 (* Expanding/testing/exposing existential variables *)
@@ -62,31 +67,43 @@ let rec flush_and_check_evars sigma c =
 
 (* 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 rec whd_evar sigma c =
+  match kind_of_term c with
+    | Evar (evk, args) ->
+      begin match safe_evar_info sigma evk with
+      | Some ({ evar_body = Evar_defined c } as info) ->
+        let args = Array.map (fun c -> whd_evar sigma c) args in
+        let c = instantiate_evar_array info c args in
+        whd_evar sigma c
+      | _ -> c
+      end
+    | 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 rec nf_evar sigma t = Constr.map (fun t -> nf_evar sigma t) (whd_evar sigma t)
+
 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) 
+  Universes.nf_evars_and_universes_opt_subst (safe_evar_value evm) 
     (Evd.universe_subst evm)
     
 let nf_evars_and_universes evm =
@@ -106,10 +123,10 @@ let nf_evar_map_universes evm =
 	Evd.raw_map (fun _ -> map_evar_info f) evm, f
 
 let nf_named_context_evar sigma ctx =
-  Context.map_named_context (nf_evar sigma) ctx
+  Context.Named.map (nf_evar sigma) ctx
 
 let nf_rel_context_evar sigma ctx =
-  Context.map_rel_context (nf_evar sigma) ctx
+  Context.Rel.map (nf_evar sigma) ctx
 
 let nf_env_evar sigma env =
   let nc' = nf_named_context_evar sigma (Environ.named_context env) in
@@ -150,11 +167,16 @@ let is_ground_term evd t =
   not (has_undefined_evars evd t)
 
 let is_ground_env evd env =
-  let is_ground_decl = function
-      (_,Some b,_) -> is_ground_term evd b
+  let open Context.Rel.Declaration in
+  let is_ground_rel_decl = function
+    | LocalDef (_,b,_) -> is_ground_term evd b
+    | _ -> true in
+  let open Context.Named.Declaration in
+  let is_ground_named_decl = function
+    | LocalDef (_,b,_) -> is_ground_term evd b
     | _ -> true in
-  List.for_all is_ground_decl (rel_context env) &&
-  List.for_all is_ground_decl (named_context env)
+  List.for_all is_ground_rel_decl (rel_context env) &&
+  List.for_all is_ground_named_decl (named_context env)
 
 (* Memoization is safe since evar_map and environ are applicative
    structures *)
@@ -176,6 +198,7 @@ let head_evar =
     | Case (_,_,c,_) -> hrec c
     | App (c,_)      -> hrec c
     | Cast (c,_,_)   -> hrec c
+    | Proj (p, c)    -> hrec c
     | _              -> raise NoHeadEvar
   in
   hrec
@@ -232,24 +255,14 @@ let non_instantiated sigma =
 (************************)
 
 let make_pure_subst evi args =
+  let open Context.Named.Declaration in
   snd (List.fold_right
-    (fun (id,b,c) (args,l) ->
+    (fun decl (args,l) ->
       match args with
-        | a::rest -> (rest, (id,a)::l)
+        | a::rest -> (rest, (get_id decl, a)::l)
         | _ -> anomaly (Pp.str "Instance does not match its signature"))
     (evar_filtered_context evi) (Array.rev_to_list args,[]))
 
-(**********************)
-(* Creating new evars *)
-(**********************)
-
-let evar_counter_summary_name = "evar counter"
-
-(* Generator of existential names *)
-let new_untyped_evar =
-  let evar_ctr = Summary.ref 0 ~name:evar_counter_summary_name in
-  fun () -> incr evar_ctr; Evar.unsafe_of_int !evar_ctr
-
 (*------------------------------------*
  * functional operations on evar sets *
  *------------------------------------*)
@@ -283,69 +296,110 @@ let new_untyped_evar =
  *   we have the property that u and phi(t) are convertible in env.
  *)
 
+let csubst_subst (k, s) c =
+  let rec subst n c = match Constr.kind c with
+  | Rel m ->
+    if m <= n then c
+    else if m - n <= k then Int.Map.find (k - m + n) s
+    else mkRel (m - k)
+  | _ -> Constr.map_with_binders succ subst n c
+  in
+  if k = 0 then c else subst 0 c
+
 let subst2 subst vsubst c =
-  substl subst (replace_vars vsubst c)
+  csubst_subst 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 next_ident_away id avoid =
+  let avoid id = Id.Set.mem id avoid in
+  next_ident_away_from id avoid
+
+let next_name_away na avoid =
+  let avoid id = Id.Set.mem id avoid in
+  let id = match na with Name id -> id | Anonymous -> default_non_dependent_ident in
+  next_ident_away_from id avoid
+
+type csubst = int * Constr.t Int.Map.t
+
+let empty_csubst = (0, Int.Map.empty)
+
+type ext_named_context =
+  csubst * (Id.t * Constr.constr) list *
+  Id.Set.t * Context.Named.t
+
+let push_var id (n, s) =
+  let s = Int.Map.add n (mkVar id) s in
+  (succ n, s)
+
+let push_rel_decl_to_named_context decl (subst, vsubst, avoid, nc) =
+  let open Context.Named.Declaration in
+  let replace_var_named_declaration id0 id decl =
+    let id' = get_id decl in
     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
+    decl |> set_id id' |> map_constr (replace_vars vsubst)
   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, 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)
+  let open Context.Rel.Declaration in
+  let (na, c, t) = to_tuple decl in
+  let open Context.Named.Declaration in
+  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
+      (** id_of_name_using_hdchar only depends on the rel context which is empty
+          here *)
+      next_ident_away (id_of_name_using_hdchar empty_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 = (fst subst, Int.Map.map (replace_vars [id0,mkVar id]) (snd subst)) in
+      let vsubst = (id0,mkVar id)::vsubst in
+      let d = match c with
+        | None -> LocalAssum (id0, subst2 subst vsubst t)
+        | Some c -> LocalDef (id0, subst2 subst vsubst c, subst2 subst vsubst t)
+      in
+      let nc = List.map (replace_var_named_declaration id0 id) nc in
+      (push_var id0 subst, vsubst, Id.Set.add id avoid, d :: nc)
+  | _ ->
+      (* 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 = match c with
+        | None -> LocalAssum (id, subst2 subst vsubst t)
+        | Some c -> LocalDef (id, subst2 subst vsubst c, subst2 subst vsubst t)
+      in
+      (push_var id subst, vsubst, Id.Set.add id avoid, d :: nc)
+
+let push_rel_context_to_named_context env typ =
+  (* compute the instances relative to the named context and rel_context *)
+  let open Context.Named.Declaration in
+  let ids = List.map get_id (named_context env) in
+  let inst_vars = List.map mkVar ids in
+  if List.is_empty (Environ.rel_context env) then
+    (named_context_val env, typ, inst_vars, empty_csubst, [])
+  else
+    let avoid = List.fold_right Id.Set.add ids Id.Set.empty in
+    let inst_rels = List.rev (rel_list 0 (nb_rel env)) 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, vsubst, _, env) =
+      Context.Rel.fold_outside push_rel_decl_to_named_context
+        (rel_context env) ~init:(empty_csubst, [], avoid, named_context env) in
+    (val_of_named_context env, subst2 subst vsubst typ, inst_rels@inst_vars, subst, vsubst)
 
 (*------------------------------------*
  * Entry points to define new evars   *
@@ -354,39 +408,41 @@ let push_rel_context_to_named_context env typ =
 let default_source = (Loc.ghost,Evar_kinds.InternalHole)
 
 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 evd = Sigma.to_evar_map evd in
+  let evd, evk' = Evd.restrict evk filter ?candidates evd in
+  Sigma.Unsafe.of_pair (evk', Evd.declare_future_goal evk' evd)
 
 let new_pure_evar_full evd evi =
-  let evk = new_untyped_evar () in
-  let evd = Evd.add evd evk evi in
+  let evd = Sigma.to_evar_map evd in
+  let (evd, evk) = Evd.new_evar evd 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
+  Sigma.Unsafe.of_pair (evk, evd)
+
+let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?candidates ?(store = Store.empty) ?naming ?(principal=false) typ =
+  let evd = Sigma.to_evar_map evd in
+  let default_naming = 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 ?store ~naming evd in
+  let evi = {
+    evar_hyps = sign;
+    evar_concl = typ;
+    evar_body = Evar_empty;
+    evar_filter = filter;
+    evar_source = src;
+    evar_candidates = candidates;
+    evar_extra = store; }
+  in
+  let (evd, newevk) = Evd.new_evar evd ~naming evi in
   let evd =
     if principal then Evd.declare_principal_goal newevk evd
     else Evd.declare_future_goal newevk evd
   in
-  (evd,newevk)
+  Sigma.Unsafe.of_pair (newevk, evd)
 
 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 sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in
-  (evd,mkEvar (newevk,Array.of_list instance))
+  let Sigma (newevk, evd, p) = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in
+  Sigma (mkEvar (newevk,Array.of_list instance), evd, p)
 
 (* [new_evar] declares a new existential in an env env with type typ *)
 (* Converting the env into the sign of the evar to define *)
@@ -399,19 +455,26 @@ let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
     | Some filter -> Filter.filter_list filter instance in
   new_evar_instance sign evd typ' ?src ?filter ?candidates ?store ?naming ?principal instance
 
+let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
+  let evd = Sigma.Unsafe.of_evar_map evd in
+  let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in
+  (Sigma.to_evar_map evd, evk)
+
 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)
+  let Sigma (s, evd', p) = Sigma.new_sort_variable rigid evd in
+  let Sigma (e, evd', q) = new_evar env evd' ?src ?filter ?naming ?principal (mkSort s) in
+  Sigma ((e, s), evd', p +> q)
 
 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';
+  let sigma = Sigma.Unsafe.of_evar_map !evdref in
+  let Sigma (c, sigma, _) = new_type_evar env sigma ?src ?filter ?naming ?principal rigid in
+  let sigma = Sigma.to_evar_map sigma in
+    evdref := sigma;
     c
 
 let new_Type ?(rigid=Evd.univ_flexible) env evd = 
-  let evd', s = new_sort_variable rigid evd in
-    evd', mkSort s
+  let Sigma (s, sigma, p) = Sigma.new_sort_variable rigid evd in
+  Sigma (mkSort s, sigma, p)
 
 let e_new_Type ?(rigid=Evd.univ_flexible) env evdref =
   let evd', s = new_sort_variable rigid !evdref in
@@ -419,7 +482,7 @@ let e_new_Type ?(rigid=Evd.univ_flexible) env evdref =
 
   (* 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
+  let (evd',ev) = new_evar_unsafe env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in
   evdref := evd';
   ev
 
@@ -447,27 +510,30 @@ let cleared = Store.field ()
 
 exception Depends of Id.t
 
-let rec check_and_clear_in_constr env evdref err ids c =
+let rec check_and_clear_in_constr env evdref err ids global 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 Id.Set.mem id' ids then
-      raise (ClearDependencyError (id',err))
-  in
+     evars). [global] should be true iff there is some variable of [ids] which
+     is a section variable *)
     match kind_of_term c with
       | Var id' ->
-	  check id'; c
+      if Id.Set.mem id' ids then raise (ClearDependencyError (id', err)) else c
 
       | ( Const _ | Ind _ | Construct _ ) ->
-          let vars = Environ.vars_of_global env c in
-            Id.Set.iter check vars; c
+        let () = if global then
+          let check id' =
+            if Id.Set.mem id' ids then
+              raise (ClearDependencyError (id',err))
+          in
+          Id.Set.iter check (Environ.vars_of_global env c)
+        in
+        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 env evdref err ids nc)
+	      (check_and_clear_in_constr env evdref err ids global nc)
 	  else
 	    (* We check for dependencies to elements of ids in the
 	       evar_info corresponding to e and in the instance of
@@ -478,7 +544,7 @@ let rec check_and_clear_in_constr env evdref err ids c =
 	    let ctxt = Evd.evar_filtered_context evi in
 	    let (rids,filter) =
               List.fold_right2
-                (fun (rid, ob,c as h) a (ri,filter) ->
+                (fun h a (ri,filter) ->
                   try
                   (* Check if some id to clear occurs in the instance
                      a of rid in ev and remember the dependency *)
@@ -494,14 +560,16 @@ let rec check_and_clear_in_constr env evdref err ids c =
                     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))
+                  with Depends id -> let open Context.Named.Declaration in
+                                     (Id.Map.add (get_id h) 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
                 let nids = Id.Map.domain rids in
-                check_and_clear_in_constr env evdref (EvarTypingBreak ev) nids (evar_concl evi)
+                let global = Id.Set.exists is_section_variable nids in
+                check_and_clear_in_constr env evdref (EvarTypingBreak ev) nids global (evar_concl evi)
 	      with ClearDependencyError (rid,err) ->
 		raise (ClearDependencyError (Id.Map.find rid rids,err)) in
 
@@ -509,7 +577,9 @@ let rec check_and_clear_in_constr env evdref err ids 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
+              let evd = Sigma.Unsafe.of_evar_map !evdref in
+              let Sigma (_, evd, _) = restrict_evar evd evk filter None in
+              let evd = Sigma.to_evar_map evd in
               evdref := evd;
 	    (* spiwack: hacking session to mark the old [evk] as having been "cleared" *)
 	      let evi = Evd.find !evdref evk in
@@ -520,20 +590,20 @@ let rec check_and_clear_in_constr env evdref err ids c =
 	    (* spiwack: /hacking session *)
               whd_evar !evdref c
 
-      | _ -> map_constr (check_and_clear_in_constr env evdref err ids) c
+      | _ -> map_constr (check_and_clear_in_constr env evdref err ids global) c
 
 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 occurring in evi *)
+  let global = Id.Set.exists is_section_variable ids in
   let terms =
-    List.map (check_and_clear_in_constr env evdref (OccurHypInSimpleClause None) ids) terms in
+    List.map (check_and_clear_in_constr env evdref (OccurHypInSimpleClause None) ids global) terms in
   let nhyps =
-    let check_context ((id,ob,c) as decl) =
-      let err = OccurHypInSimpleClause (Some id) in
-      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')
+    let open Context.Named.Declaration in
+    let check_context decl =
+      let err = OccurHypInSimpleClause (Some (get_id decl)) in
+      map_constr (check_and_clear_in_constr env evdref err ids global) decl
     in
     let check_value vk = match force_lazy_val vk with
     | None -> vk
@@ -571,11 +641,12 @@ let process_dependent_evar q acc evm is_dependent e =
   (* Queues evars appearing in the types of the goal (conclusion, then
      hypotheses), they are all dependent. *)
   queue_term q true evi.evar_concl;
-  List.iter begin fun (_,b,t) ->
-    queue_term q true t;
-    match b with
-    | None -> ()
-    | Some b -> queue_term q true b
+  List.iter begin fun decl ->
+    let open Context.Named.Declaration in
+    queue_term q true (get_type decl);
+    match decl with
+    | LocalAssum _ -> ()
+    | LocalDef (_,b,_) -> queue_term q true b
   end (Environ.named_context_of_val evi.evar_hyps);
   match evi.evar_body with
   | Evar_empty ->
@@ -607,6 +678,28 @@ let gather_dependent_evars evm l =
 
 (* /spiwack *)
 
+(** [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 evk =
+  let evi = Evd.find sigma evk in
+  match evi.evar_body with
+  | Evar_empty -> Some evk
+  | Evar_defined v ->
+      if Option.default false (Store.get evi.evar_extra cleared) then
+        let (evk,_) = Term.destEvar v in
+        advance sigma evk
+      else
+        None
+
 (** 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
@@ -626,11 +719,11 @@ let undefined_evars_of_term evd 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 ->
-      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 open Context.Named.Declaration in
+  Context.Named.fold_outside
+    (fold (fun c s -> Evar.Set.union s (undefined_evars_of_term evd c)))
+    nc
+    ~init:Evar.Set.empty
 
 let undefined_evars_of_evar_info evd evi =
   Evar.Set.union (undefined_evars_of_term evd evi.evar_concl)
@@ -641,23 +734,6 @@ let undefined_evars_of_evar_info evd evi =
        (undefined_evars_of_named_context evd
 	  (named_context_of_val evi.evar_hyps)))
 
-(* [check_evars] fails if some unresolved evar remains *)
-
-let check_evars env initial_sigma sigma c =
-  let rec proc_rec c =
-    match kind_of_term c with
-    | Evar (evk,_ as ev) ->
-        (match existential_opt_value sigma ev with
-        | Some c -> proc_rec c
-        | None ->
-	  if not (Evd.mem initial_sigma evk) then
-            let (loc,k) = evar_source evk sigma in
-	      match k with
-	      | Evar_kinds.ImplicitArg (gr, (i, id), false) -> ()
-	      | _ -> error_unsolvable_implicit loc env sigma evk None)
-      | _ -> iter_constr proc_rec c
-  in proc_rec c
-
 (* 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
@@ -670,176 +746,12 @@ let occur_evar_upto sigma n c =
   in
   try occur_rec c; false with Occur -> true
 
-
-(****************************************)
-(* Operations on value/type constraints *)
-(****************************************)
-
-type type_constraint = types option
-
-type val_constraint = constr option
-
-(* Old comment...
- * Basically, we have the following kind of constraints (in increasing
- * strength order):
- *   (false,(None,None)) -> no constraint at all
- *   (true,(None,None))  -> we must build a judgement which _TYPE is a kind
- *   (_,(None,Some ty))  -> we must build a judgement which _TYPE is ty
- *   (_,(Some v,_))      -> we must build a judgement which _VAL is v
- * Maybe a concrete datatype would be easier to understand.
- * We differentiate (true,(None,None)) from (_,(None,Some Type))
- * because otherwise Case(s) would be misled, as in
- * (n:nat) Case n of bool [_]nat end  would infer the predicate Type instead
- * of Set.
- *)
-
-(* The empty type constraint *)
-let empty_tycon = None
-
-(* Builds a type constraint *)
-let mk_tycon ty = Some ty
-
-(* Constrains the value of a type *)
-let empty_valcon = None
-
-(* Builds a value constraint *)
-let mk_valcon c = Some c
-
-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_env evi in
-  let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in
-  let concl = whd_betadeltaiota evenv 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 = 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 status = univ_flexible_alg in
-	let evd3, (rng, srng) =
-	  new_type_evar newenv evd1 status ~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
-
-(* Refine an applied evar to a product and returns its instantiation *)
-
-let define_evar_as_product evd (evk,args) =
-  let evd,prod = define_pure_evar_as_product evd evk in
-  (* 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 evrng =  mkEvar (fst (destEvar rng), evrngargs) in
-  evd,mkProd (na, evdom, evrng)
-
-(* Refine an evar with an abstraction
-
-   I.e., solve x1..xq |- ?e:T(x1..xq) with e:=λy:A.?e'[x1..xq,y] where:
-   - either T(x1..xq) = πy:A(x1..xq).B(x1..xq,y)
-     or T(x1..xq) = ?d[x1..xq] and we define ?d := πy:?A.?B
-        with x1..xq |- ?A:Type and x1..xq,y |- ?B:Type
-   - x1..xq,y:A |- ?e':B
-*)
-
-let define_pure_evar_as_lambda env evd evk =
-  let evi = Evd.find_undefined evd evk in
-  let evenv = evar_env evi in
-  let typ = whd_betadeltaiota evenv 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 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 = Filter.extend 1 (evar_filter evi) in
-  let src = evar_source evk evd1 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
-
-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 evbody = mkEvar (fst (destEvar body), evbodyargs) in
-  evd,mkLambda (na, dom, evbody)
-
-let rec evar_absorb_arguments env evd (evk,args as ev) = function
-  | [] -> evd,ev
-  | a::l ->
-      (* TODO: optimize and avoid introducing intermediate evars *)
-      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
-
-(* Refining an evar to a sort *)
-
-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 concl = whd_betadeltaiota (evar_env evi) evd evi.evar_concl in
-  let sort = destSort concl in
-  let evd' = Evd.define ev (mkSort s) evd in
-  Evd.set_leq_sort env evd' (Type (Univ.super u)) sort, 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 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 split_tycon 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 (* ev is undefined because of whd_betadeltaiota *) ->
-	    let (evd',prod) = define_evar_as_product evd ev in
-	    let (_,dom,rng) = destProd prod in
-	      evd',(Anonymous, dom, rng)
-	| App (c,args) when isEvar c ->
-	    let (evd',lam) = define_evar_as_lambda env evd (destEvar c) in
-	    real_split evd' (mkApp (lam,args))
-	| _ -> error_not_product_loc loc env evd c
-  in
-    match tycon with
-      | None -> evd,(Anonymous,None,None)
-      | 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 -> Termops.print_constr_env env t
+  let Sigma (s, evd', p) = Sigma.new_univ_variable univ_rigid evd in
+  Sigma ({ uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }, evd', p)
 
 let subterm_source evk (loc,k) =
   let evk = match k with
@@ -850,7 +762,7 @@ let subterm_source evk (loc,k) =
 
 (** Term exploration up to instantiation. *)
 let kind_of_term_upto sigma t =
-  Constr.kind (Reductionops.whd_evar sigma t)
+  Constr.kind (whd_evar sigma t)
 
 (** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and
     [u] up to existential variable instantiation and equalisable
@@ -860,13 +772,17 @@ let kind_of_term_upto sigma t =
 let eq_constr_univs_test sigma1 sigma2 t u =
   (* spiwack: mild code duplication with {!Evd.eq_constr_univs}. *)
   let open Evd in
-  let b, c =
+  let fold cstr sigma =
+    try Some (add_universe_constraints sigma cstr)
+    with Univ.UniverseInconsistency _ | UniversesDiffer -> None
+  in
+  let ans =
     Universes.eq_constr_univs_infer_with
       (fun t -> kind_of_term_upto sigma1 t)
       (fun u -> kind_of_term_upto sigma2 u)
-      (universes sigma2) t u
+      (universes sigma2) fold t u sigma2
   in
-  if b then
-    try let _ = add_universe_constraints sigma2 c in true
-    with Univ.UniverseInconsistency _ | UniversesDiffer -> false
-  else false
+  match ans with None -> false | Some _ -> true
+
+type type_constraint = types option
+type val_constraint = constr option
diff --git a/pretyping/evarutil.mli b/engine/evarutil.mli
index f68651a7..7fdc7aac 100644
--- a/pretyping/evarutil.mli
+++ b/engine/evarutil.mli
@@ -8,11 +8,10 @@
 
 open Names
 open Term
-open Context
 open Evd
 open Environ
 
-(** {5 This modules provides useful functions for unification modulo evars } *)
+(** This module provides useful higher-level functions for evar manipulation. *)
 
 (** {6 Metas} *)
 
@@ -22,18 +21,18 @@ val mk_new_meta : unit -> constr
 
 (** {6 Creating a fresh evar given their type and context} *)
 val new_evar :
-  env -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
+  env -> 'r Sigma.t -> ?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
+  ?principal:bool -> types -> (constr, 'r) Sigma.sigma
 
 val new_pure_evar :
-  named_context_val -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
+  named_context_val -> 'r Sigma.t -> ?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
+  ?principal:bool -> types -> (evar, 'r) Sigma.sigma
 
-val new_pure_evar_full : evar_map -> evar_info -> evar_map * evar
+val new_pure_evar_full : 'r Sigma.t -> evar_info -> (evar, 'r) Sigma.sigma
 
 (** the same with side-effects *)
 val e_new_evar :
@@ -45,23 +44,23 @@ val e_new_evar :
 (** Create a new Type existential variable, as we keep track of 
     them during type-checking and unification. *)
 val new_type_evar :
-  env -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
+  env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
   ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid ->
-  evar_map * (constr * sorts)
+  (constr * sorts, 'r) Sigma.sigma
 
 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 new_Type : ?rigid:rigid -> env -> 'r Sigma.t -> (constr, 'r) Sigma.sigma
 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
+val restrict_evar : 'r Sigma.t -> existential_key -> Filter.t ->
+  constr list option -> (existential_key, 'r) Sigma.sigma
 
 (** Polymorphic constants *)
 
-val new_global : evar_map -> Globnames.global_reference -> evar_map * constr
+val new_global : 'r Sigma.t -> Globnames.global_reference -> (constr, 'r) Sigma.sigma
 val e_new_global : evar_map ref -> Globnames.global_reference -> constr
 
 (** Create a fresh evar in a context different from its definition context:
@@ -71,14 +70,16 @@ val e_new_global : evar_map ref -> Globnames.global_reference -> constr
    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.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> 
+ named_context_val -> 'r Sigma.t -> 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
+  constr list -> (constr, 'r) Sigma.sigma
 
 val make_pure_subst : evar_info -> constr array -> (Id.t * constr) list
 
+val safe_evar_value : evar_map -> existential -> constr option
+
 (** {6 Evars/Metas switching...} *)
 
 val non_instantiated : evar_map -> evar_info Evar.Map.t
@@ -97,20 +98,6 @@ val has_undefined_evars : evar_map -> constr -> bool
 
 val is_ground_term :  evar_map -> constr -> bool
 val is_ground_env  :  evar_map -> env -> 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 : 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
 
 (** [gather_dependent_evars evm seeds] classifies the evars in [evm]
     as dependent_evars and goals (these may overlap). A goal is an
@@ -123,13 +110,19 @@ val evar_absorb_arguments : env -> evar_map -> existential -> constr list ->
     its (partial) definition. *)
 val gather_dependent_evars : evar_map -> evar list -> (Evar.Set.t option) Evar.Map.t
 
+(** [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. *)
+val advance : evar_map -> evar -> evar option
+
 (** 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 -> Evar.Set.t
-val undefined_evars_of_named_context : evar_map -> named_context -> Evar.Set.t
+val undefined_evars_of_named_context : evar_map -> Context.Named.t -> 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
@@ -139,28 +132,14 @@ 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 = types option
-type val_constraint = constr option
-
-val empty_tycon : type_constraint
-val mk_tycon : constr -> type_constraint
-val empty_valcon : val_constraint
-val mk_valcon : constr -> val_constraint
-
-val split_tycon :
-  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_tycon : int -> type_constraint -> type_constraint
+val judge_of_new_Type : 'r Sigma.t -> (unsafe_judgment, 'r) Sigma.sigma
 
 (***********************************************************)
 
 (** [flush_and_check_evars] raise [Uninstantiated_evar] if an evar remains
     uninstantiated; [nf_evar] leaves uninstantiated evars as is *)
 
+val whd_evar :  evar_map -> constr -> constr
 val nf_evar :  evar_map -> constr -> constr
 val j_nf_evar :  evar_map -> unsafe_judgment -> unsafe_judgment
 val jl_nf_evar :
@@ -170,20 +149,14 @@ val jv_nf_evar :
 val tj_nf_evar :
    evar_map -> unsafe_type_judgment -> unsafe_type_judgment
 
-val nf_named_context_evar : evar_map -> named_context -> named_context
-val nf_rel_context_evar : evar_map -> rel_context -> rel_context
+val nf_named_context_evar : evar_map -> Context.Named.t -> Context.Named.t
+val nf_rel_context_evar : evar_map -> Context.Rel.t -> Context.Rel.t
 val nf_env_evar : evar_map -> env -> env
 
 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
@@ -213,11 +186,6 @@ val kind_of_term_upto : evar_map -> constr -> (constr,types) kind_of_term
     assumed to be an extention of those in [sigma1]. *)
 val eq_constr_univs_test : evar_map -> evar_map -> constr -> constr -> bool
 
-(** {6 debug pretty-printer:} *)
-
-val pr_tycon : env -> type_constraint -> Pp.std_ppcmds
-
-
 (** {6 Removing hyps in evars'context}
 raise OccurHypInSimpleClause if the removal breaks dependencies *)
 
@@ -237,8 +205,20 @@ val clear_hyps_in_evi : env -> evar_map ref -> 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
 
+type csubst
+
+val empty_csubst : csubst
+val csubst_subst : csubst -> Constr.t -> Constr.t
+
+type ext_named_context =
+  csubst * (Id.t * Constr.constr) list *
+  Id.Set.t * Context.Named.t
+
+val push_rel_decl_to_named_context :
+  Context.Rel.Declaration.t -> ext_named_context -> ext_named_context
+
 val push_rel_context_to_named_context : Environ.env -> types ->
-  named_context_val * types * constr list * constr list * (identifier*constr) list
+  named_context_val * types * constr list * csubst * (identifier*constr) list
 
 val generalize_evar_over_rels : evar_map -> existential -> types * constr list
 
@@ -252,4 +232,8 @@ val subterm_source : existential_key -> Evar_kinds.t Loc.located ->
   Evar_kinds.t Loc.located
 
 val meta_counter_summary_name : string
-val evar_counter_summary_name : string
+
+(** Deprecater *)
+
+type type_constraint = types option
+type val_constraint = constr option
diff --git a/pretyping/evd.ml b/engine/evd.ml
index 01083142..a6b6f742 100644
--- a/pretyping/evd.ml
+++ b/engine/evd.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
@@ -16,6 +16,7 @@ open Vars
 open Termops
 open Environ
 open Globnames
+open Context.Named.Declaration
 
 (** Generic filters *)
 module Filter :
@@ -208,15 +209,6 @@ let map_evar_info f evi =
     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
 
@@ -230,20 +222,20 @@ let evar_instance_array test_id info args =
     else instance_mismatch ()
   | false :: filter, _ :: ctxt ->
     instrec filter ctxt i
-  | true :: filter, (id,_,_ as d) :: ctxt ->
+  | true :: filter, d :: ctxt ->
     if i < len then
       let c = Array.unsafe_get args i in
       if test_id d c then instrec filter ctxt (succ i)
-      else (id, c) :: instrec filter ctxt (succ i)
+      else (get_id d, c) :: instrec filter ctxt (succ i)
     else instance_mismatch ()
   | _ -> instance_mismatch ()
   in
   match Filter.repr (evar_filter info) with
   | None ->
-    let map i (id,_,_ as d) =
+     let map i d =
       if (i < len) then
         let c = Array.unsafe_get args i in
-        if test_id d c then None else Some (id,c)
+        if test_id d c then None else Some (get_id d, c)
       else instance_mismatch ()
     in
     List.map_filter_i map (evar_context info)
@@ -251,7 +243,7 @@ let evar_instance_array test_id info args =
     instrec filter (evar_context info) 0
 
 let make_evar_instance_array info args =
-  evar_instance_array (fun (id,_,_) -> isVarId id) info args
+  evar_instance_array (isVarId % get_id) info args
 
 let instantiate_evar_array info c args =
   let inst = make_evar_instance_array info args in
@@ -259,234 +251,23 @@ let instantiate_evar_array info c args =
   | [] -> 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
-
-(* 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 inferred types 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 newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local)
-			       (Univ.ContextSet.levels ctx.uctx_local) in
-    let newus = Univ.LSet.diff newus (Univ.LMap.domain ctx.uctx_univ_variables) in
-    let declarenew g =
-      Univ.LSet.fold (fun u g -> Univ.add_universe u false g) newus g
-    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 = declarenew 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 (declarenew 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 evar_universe_context = UState.t
 
 type 'a in_evar_universe_context = 'a * evar_universe_context
 
-let evar_universe_context_set diff ctx =
-  let initctx = ctx.uctx_local in
-  let cstrs =
-    Univ.LSet.fold
-      (fun l cstrs ->
-       try
-	 match Univ.LMap.find l ctx.uctx_univ_variables with
-	 | Some u -> Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs
-	 | None -> cstrs
-       with Not_found | Option.IsNone -> cstrs)
-      (Univ.Instance.levels (Univ.UContext.instance diff)) Univ.Constraint.empty
-  in
-    Univ.ContextSet.add_constraints cstrs initctx 
-		      
-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 add_uctx_names s l (names, names_rev) =
-  (UNameMap.add s l names, Univ.LMap.add l s names_rev)
-
-let evar_universe_context_of_binders b =
-  let ctx = empty_evar_universe_context in
-  let names =
-    List.fold_left (fun acc (id, l) -> add_uctx_names (Id.to_string id) l acc)
-		   ctx.uctx_names b
-  in { ctx with uctx_names = names }
-					
-let instantiate_variable l b v =
-  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
-			unify_universes fo (Univ.Universe.make l) Universes.UEq 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
-	    | Inr (l, loc, alg), Inl r
-	    | Inl r, Inr (l, loc, alg) ->
-	       let inst = Univ.univ_level_rem l r r in
-		 if alg then (instantiate_variable l inst vars; local)
-		 else
-		   let lu = Univ.Universe.make l in
-		   if Univ.univ_level_mem l r then
-		     Univ.enforce_leq inst lu local
-		   else raise (Univ.UniverseInconsistency (Univ.Eq, lu, r, None))
-            | _, _ (* 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 local' 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 empty_evar_universe_context = UState.empty
+let is_empty_evar_universe_context = UState.is_empty
+let union_evar_universe_context = UState.union
+let evar_universe_context_set = UState.context_set
+let evar_universe_context_constraints = UState.constraints
+let evar_context_universe_context = UState.context
+let evar_universe_context_of = UState.of_context_set
+let evar_universe_context_subst = UState.subst
+let add_constraints_context = UState.add_constraints
+let add_universe_constraints_context = UState.add_universe_constraints
+let constrain_variables = UState.constrain_variables 
+let evar_universe_context_of_binders = UState.of_binders
 
-(* let addunivconstrkey = Profile.declare_profile "add_universe_constraints_context";; *)
-(* let add_universe_constraints_context =  *)
-(*   Profile.profile2 addunivconstrkey add_universe_constraints_context;; *)
 (*******************************************************************)
 (* Metamaps *)
 
@@ -575,11 +356,85 @@ type evar_constraint = conv_pb * Environ.env * constr * constr
 
 module EvMap = Evar.Map
 
+module EvNames :
+sig
+
+open Misctypes
+
+type t
+
+val empty : t
+val add_name_undefined : intro_pattern_naming_expr -> Evar.t -> evar_info -> t -> t
+val remove_name_defined : Evar.t -> t -> t
+val rename : Evar.t -> Id.t -> t -> t
+val reassign_name_defined : Evar.t -> Evar.t -> t -> t
+val ident : Evar.t -> t -> Id.t option
+val key : Id.t -> t -> Evar.t
+
+end =
+struct
+
+type t = Id.t EvMap.t * existential_key Idmap.t
+
+let empty = (EvMap.empty, Idmap.empty)
+
+let add_name_newly_undefined naming evk evi (evtoid, idtoev as names) =
+  let id = match naming with
+  | Misctypes.IntroAnonymous -> None
+  | Misctypes.IntroIdentifier id ->
+    if Idmap.mem id idtoev then
+    user_err_loc
+      (Loc.ghost,"",str "Already an existential evar of name " ++ pr_id id);
+    Some id
+  | Misctypes.IntroFresh id ->
+    let id = Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in
+    Some id
+  in
+  match id with
+  | None -> names
+  | Some id -> (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 as names) =
+  let id = try Some (EvMap.find evk evtoid) with Not_found -> None in
+  match id with
+  | None -> names
+  | Some id -> (EvMap.remove evk evtoid, Idmap.remove id idtoev)
+
+let rename evk id (evtoid, idtoev) =
+  let id' = try Some (EvMap.find evk evtoid) with Not_found -> None in
+  match id' with
+  | None -> (EvMap.add evk id evtoid, Idmap.add id evk idtoev)
+  | Some id' ->
+    if Idmap.mem id idtoev then anomaly (str "Evar name already in use");
+    (EvMap.update evk id evtoid (* overwrite old name *), Idmap.add id evk (Idmap.remove id' idtoev))
+
+let reassign_name_defined evk evk' (evtoid, idtoev as names) =
+  let id = try Some (EvMap.find evk evtoid) with Not_found -> None in
+  match id with
+  | None -> names (** evk' must not be defined *)
+  | Some id ->
+    (EvMap.add evk' id (EvMap.remove evk evtoid),
+    Idmap.add id evk' (Idmap.remove id idtoev))
+
+let ident evk (evtoid, _) =
+  try Some (EvMap.find evk evtoid) with Not_found -> None
+
+let key id (_, idtoev) =
+  Idmap.find id idtoev
+
+end
+
 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;
+  evar_names : EvNames.t;
   (** Universes *)
   universes  : evar_universe_context;
   (** Conversion problems *)
@@ -604,57 +459,33 @@ type evar_map = {
 
 (*** Lifting primitive from Evar.Map. ***)
 
-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
+  { evd with evar_names = EvNames.rename evk id evd.evar_names }
+
+let add_with_name ?(naming = Misctypes.IntroAnonymous) d e i = match i.evar_body with
 | Evar_empty ->
-  let evar_names = add_name_undefined Misctypes.IntroAnonymous e i d.evar_names in
+  let evar_names = EvNames.add_name_undefined naming 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
+  let evar_names = EvNames.remove_name_defined e d.evar_names in
   { d with defn_evars = EvMap.add e i d.defn_evars; evar_names }
 
+let add d e i = add_with_name d e i
+
+(** New evars *)
+
+let evar_counter_summary_name = "evar counter"
+
+(* Generator of existential names *)
+let new_untyped_evar =
+  let evar_ctr = Summary.ref 0 ~name:evar_counter_summary_name in
+  fun () -> incr evar_ctr; Evar.unsafe_of_int !evar_ctr
+
+let new_evar evd ?naming evi =
+  let evk = new_untyped_evar () in
+  let evd = add_with_name evd ?naming evk evi in
+  (evd, evk)
+
 let remove d e =
   let undf_evars = EvMap.remove e d.undf_evars in
   let defn_evars = EvMap.remove e d.defn_evars in
@@ -770,10 +601,6 @@ let cmap f evd =
 (* spiwack: deprecated *)
 let create_evar_defs sigma = { sigma with
   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=Evar.Set.empty; metas=Metamap.empty } *)
-  metas=Metamap.empty } 
 
 let empty = {
   defn_evars = EvMap.empty;
@@ -783,14 +610,14 @@ let empty = {
   last_mods  = Evar.Set.empty;
   metas      = Metamap.empty;
   effects    = Safe_typing.empty_private_constants;
-  evar_names = (EvMap.empty,Idmap.empty); (* id<->key for undefined evars *)
+  evar_names = EvNames.empty; (* id<->key for undefined evars *)
   future_goals = [];
   principal_future_goal = None;
   extras = Store.empty;
 }
 
 let from_env e = 
-  { empty with universes = evar_universe_context_from e }
+  { empty with universes = UState.make (Environ.universes e) }
 
 let from_ctx ctx = { empty with universes = ctx }
 
@@ -814,19 +641,14 @@ let set_universe_context evd uctx' =
   { evd with universes = uctx' }
 
 let add_conv_pb ?(tail=false) pb d =
+  (** MS: we have duplicates here, why? *)
   if tail then {d with conv_pbs = d.conv_pbs @ [pb]}
   else {d with conv_pbs = pb::d.conv_pbs}
 
 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 evar_ident evk evd = EvNames.ident evk evd.evar_names
+let evar_key id evd = EvNames.key id evd.evar_names
 
 let define_aux def undef evk body =
   let oldinfo =
@@ -848,42 +670,23 @@ let define evk body evd =
   | [] ->  evd.last_mods
   | _ -> Evar.Set.add evk evd.last_mods
   in
-  let evar_names = remove_name_defined evk evd.evar_names in
+  let evar_names = EvNames.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 restrict evk filter ?candidates evd =
+  let evk' = new_untyped_evar () in
   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 evar_names = EvNames.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 id_inst = Array.map_of_list (mkVar % get_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 }
+    defn_evars; evar_names }, evk'
 
 let downcast evk ccl evd =
   let evar_info = EvMap.find evk evd.undf_evars in
@@ -941,10 +744,10 @@ let evars_of_term c =
   evrec Evar.Set.empty c
 
 let evars_of_named_context nc =
-  List.fold_right (fun (_, b, t) s ->
+  List.fold_right (fun decl s ->
     Option.fold_left (fun s t ->
       Evar.Set.union s (evars_of_term t))
-      (Evar.Set.union s (evars_of_term t)) b)
+      (Evar.Set.union s (evars_of_term (get_type decl))) (get_value decl))
     nc Evar.Set.empty
 
 let evars_of_filtered_evar_info evi =
@@ -958,7 +761,7 @@ let evars_of_filtered_evar_info evi =
 (**********************************************************)
 (* Sort variables *)
 
-type rigid = 
+type rigid = UState.rigid =
   | UnivRigid
   | UnivFlexible of bool (** Is substitution by an algebraic ok? *)
 
@@ -968,211 +771,80 @@ let univ_flexible_alg = UnivFlexible true
 
 let evar_universe_context d = d.universes
 
-let universe_context_set d = d.universes.uctx_local
-
-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 universe_context ?names evd =
-  match names with
-  | None -> [], Univ.ContextSet.to_context evd.universes.uctx_local
-  | Some pl ->
-     let levels = Univ.ContextSet.levels evd.universes.uctx_local in
-     let newinst, map, left =
-       List.fold_right
-         (fun (loc,id) (newinst, map, acc) ->
-	  let l =
-	    try UNameMap.find (Id.to_string id) (fst evd.universes.uctx_names)
-	    with Not_found ->
-	      user_err_loc (loc, "universe_context",
-			    str"Universe " ++ pr_id id ++ str" is not bound anymore.")
-	  in (l :: newinst, (id, l) :: map, Univ.LSet.remove l acc))
-	 pl ([], [], levels)
-     in
-       if not (Univ.LSet.is_empty left) then
-         let n = Univ.LSet.cardinal left in
-           errorlabstrm "universe_context"
-			(str(CString.plural n "Universe") ++ spc () ++
-			     Univ.LSet.pr (pr_uctx_level evd.universes) left ++
-			     spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.")
-       else
-	 let inst = Univ.Instance.of_array (Array.of_list newinst) in
-	 let ctx = Univ.UContext.make (inst,
-           Univ.ContextSet.constraints evd.universes.uctx_local)
-	 in map, ctx
+let universe_context_set d = UState.context_set d.universes
+
+let pr_uctx_level = UState.pr_uctx_level
+let universe_context ?names evd = UState.universe_context ?names evd.universes
 
 let restrict_universe_context evd vars =
-  let uctx = evd.universes in
-  let uctx' = Universes.restrict_universe_context uctx.uctx_local vars in
-    { evd with universes = { uctx with uctx_local = uctx' } }
-						 
+  { evd with universes = UState.restrict evd.universes vars }
+
 let universe_subst evd =
-  evd.universes.uctx_univ_variables
-
-let merge_uctx sideff rigid uctx ctx' =
-  let open Univ in
-  let levels = ContextSet.levels ctx' in
-  let uctx = if sideff then uctx else
-    match rigid with
-    | UnivRigid -> uctx
-    | UnivFlexible b ->
-      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 =
-    if sideff then uctx.uctx_local
-    else ContextSet.append ctx' uctx.uctx_local
-  in
-  let declare g =
-    LSet.fold (fun u g ->
-	       try Univ.add_universe u false g
-	       with Univ.AlreadyDeclared when sideff -> g)
-	      levels g
-  in
-  let initial = declare uctx.uctx_initial_universes in
-  let univs = declare uctx.uctx_universes in
-  let uctx_universes = merge_constraints (ContextSet.constraints ctx') univs in
-    { uctx with uctx_local; uctx_universes; uctx_initial_universes = initial }
+  UState.subst evd.universes
 
-let merge_context_set ?(sideff=false) rigid evd ctx' = 
-  {evd with universes = merge_uctx sideff rigid evd.universes ctx'}
+let merge_context_set ?loc ?(sideff=false) rigid evd ctx' =
+  {evd with universes = UState.merge ?loc sideff 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 emit_universe_side_effects eff u =
-  let uctxs = Safe_typing.universes_of_private eff in
-  List.fold_left (merge_uctx true univ_rigid) u uctxs
-        
-let uctx_new_univ_variable rigid name predicative
-  ({ 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', pred =
-    match rigid with
-    | UnivRigid -> uctx, true
-    | 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}, false
-	else {uctx with uctx_univ_variables = uvars'}, false
-  in
-  let names = 
-    match name with
-    | Some n -> add_uctx_names n u uctx.uctx_names
-    | None -> uctx.uctx_names
-  in
-  let initial =
-    Univ.add_universe u false uctx.uctx_initial_universes
-  in						     
-  let uctx' =
-    {uctx' with uctx_names = names; uctx_local = ctx';
-		uctx_universes = Univ.add_universe u false uctx.uctx_universes;
-		uctx_initial_universes = initial}
-  in uctx', u
-						     
-let new_univ_level_variable ?name ?(predicative=true) rigid evd =
-  let uctx', u = uctx_new_univ_variable rigid name predicative evd.universes in
+  {evd with universes = UState.merge_subst evd.universes subst }
+
+let with_context_set ?loc rigid d (a, ctx) =
+  (merge_context_set ?loc rigid d ctx, a)
+
+let new_univ_level_variable ?loc ?name rigid evd =
+  let uctx', u = UState.new_univ_variable ?loc rigid name evd.universes in
     ({evd with universes = uctx'}, u)
 
-let new_univ_variable ?name ?(predicative=true) rigid evd =
-  let uctx', u = uctx_new_univ_variable rigid name predicative evd.universes in
+let new_univ_variable ?loc ?name rigid evd =
+  let uctx', u = UState.new_univ_variable ?loc rigid name evd.universes in
     ({evd with universes = uctx'}, Univ.Universe.make u)
 
-let new_sort_variable ?name ?(predicative=true) rigid d =
-  let (d', u) = new_univ_variable rigid ?name ~predicative d in
+let new_sort_variable ?loc ?name rigid d =
+  let (d', u) = new_univ_variable ?loc rigid ?name d in
     (d', Type u)
 
 let add_global_univ d u =
-  let uctx = d.universes in
-  let initial =
-    Univ.add_universe u true uctx.uctx_initial_universes
-  in
-  let univs = 
-    Univ.add_universe u true uctx.uctx_universes
-  in
-    { d with universes = { uctx with uctx_local = Univ.ContextSet.add_universe u uctx.uctx_local;
-				     uctx_initial_universes = initial;
-				     uctx_universes = univs } }
-      
+  { d with universes = UState.add_global_univ d.universes u }
+
 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'}}
-
-let make_evar_universe_context e l = 
-  let uctx = evar_universe_context_from e in
-    match l with
-    | None -> uctx
-    | Some us ->
-       List.fold_left
-	 (fun uctx (loc,id) ->
-	  fst (uctx_new_univ_variable univ_rigid (Some (Id.to_string id)) true uctx))
-	 uctx us
-    
+  { evd with universes = UState.make_flexible_variable evd.universes b u }
+
+let make_evar_universe_context e l =
+  let uctx = UState.make (Environ.universes e) in
+  match l with
+  | None -> uctx
+  | Some us ->
+      List.fold_left
+        (fun uctx (loc,id) ->
+        fst (UState.new_univ_variable ~loc univ_rigid (Some (Id.to_string id)) uctx))
+        uctx us
+
 (****************************************)
 (* 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_sort_in_family ?loc ?(rigid=univ_flexible) env evd s = 
+  with_context_set ?loc 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 fresh_constant_instance ?loc env evd c =
+  with_context_set ?loc univ_flexible evd (Universes.fresh_constant_instance env c)
 
-let fresh_inductive_instance env evd i =
-  with_context_set univ_flexible evd (Universes.fresh_inductive_instance env i)
+let fresh_inductive_instance ?loc env evd i =
+  with_context_set ?loc 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_constructor_instance ?loc env evd c =
+  with_context_set ?loc 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 fresh_global ?loc ?(rigid=univ_flexible) ?names env evd gr =
+  with_context_set ?loc 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_sort_variable evd s = UState.is_sort_variable evd.universes s
 
 let is_flexible_level evd l = 
   let uctx = evd.universes in
-    Univ.LMap.mem l uctx.uctx_univ_variables
+    Univ.LMap.mem l (UState.subst uctx)
 
 let is_eq_sort s1 s2 =
   if Sorts.equal s1 s2 then None
@@ -1182,13 +854,20 @@ let is_eq_sort s1 s2 =
       if Univ.Universe.equal u1 u2 then None
       else Some (u1, u2)
 
+(* Precondition: l is not defined in the substitution *)
+let universe_rigidity evd l =
+  let uctx = evd.universes in
+  if Univ.LSet.mem l (Univ.ContextSet.levels (UState.context_set uctx)) then
+    UnivFlexible (Univ.LSet.mem l (UState.algebraics uctx))
+  else UnivRigid
+
 let normalize_universe evd =
-  let vars = ref evd.universes.uctx_univ_variables in
+  let vars = ref (UState.subst evd.universes) 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 vars = ref (UState.subst evd.universes) in
   let normalize = Univ.level_subst_of (Universes.normalize_univ_variable_opt_subst vars) in
     Univ.Instance.subst_fn normalize l
 
@@ -1212,12 +891,9 @@ let set_eq_sort env d s1 s2 =
       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))
+  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)
@@ -1235,107 +911,29 @@ let set_leq_sort env evd s1 s2 =
   match is_eq_sort s1 s2 with
   | None -> evd
   | Some (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
+     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'
+  UGraph.check_eq (UState.ugraph evd.universes) s s'
 
 let check_leq evd s s' =
-  Univ.check_leq evd.universes.uctx_universes s s'
+  UGraph.check_leq (UState.ugraph evd.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 = UState.normalize_variables
 
-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 fix_undefined_variables ({ universes = uctx } as evm) =
-  let algs', vars' = 
-    Univ.LMap.fold (fun u v (algs, vars as acc) ->
-      if v == None then (Univ.LSet.remove u algs, Univ.LMap.remove u vars)
-      else acc)
-      uctx.uctx_univ_variables 
-      (uctx.uctx_univ_algebraic, uctx.uctx_univ_variables)
-  in
-    {evm with universes = 
-	{ uctx with uctx_univ_variables = vars';
-	  uctx_univ_algebraic = algs' } }
+let abstract_undefined_variables = UState.abstract_undefined_variables
 
-
-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 declare g = Univ.LSet.fold (fun u g -> Univ.add_universe u false g)
-				   (Univ.ContextSet.levels ctx') g in
-  let initial = declare uctx.uctx_initial_universes in
-  let univs = declare Univ.initial_universes in
-  let uctx' = {uctx_names = uctx.uctx_names;
-	       uctx_local = ctx'; 
-	       uctx_univ_variables = vars; uctx_univ_algebraic = alg;
-	       uctx_universes = univs;
-	       uctx_initial_universes = initial } in
-    uctx', subst
+let fix_undefined_variables evd =
+  { evd with universes = UState.fix_undefined_variables evd.universes }
 
 let refresh_undefined_universes evd =
-  let uctx', subst = refresh_undefined_univ_variables evd.universes in
+  let uctx', subst = UState.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.ContextSet.equal us' 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 normalize_evar_universe_context = UState.normalize
 
 let nf_univ_variables evd = 
   let subst, uctx' = normalize_evar_universe_context_variables evd.universes in
@@ -1347,52 +945,42 @@ let nf_constraints evd =
   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 universe_of_name evd s = UState.universe_of_name evd.universes s
 
 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'}}
+  { evd with universes = UState.add_universe_name evd.universes s l }
 
-let universes evd = evd.universes.uctx_universes
+let universes evd = UState.ugraph evd.universes
 
 let update_sigma_env evd env =
-  let univs = Environ.universes env in
-  let eunivs =
-    { evd.universes with uctx_initial_universes = univs;
-			 uctx_universes = univs }
-  in
-  let eunivs = merge_uctx true univ_rigid eunivs eunivs.uctx_local in
-  { evd with universes = eunivs }
+  { evd with universes = UState.update_sigma_env evd.universes env }
 
 (* Conversion w.r.t. an evar map and its local universes. *)
 
 let test_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
+    Reduction.conv env
+      ~evars:((existential_opt_value evd), (UState.ugraph evd.universes))
+      t u
+  | Reduction.CUMUL -> Reduction.conv_leq env
+      ~evars:((existential_opt_value evd), (UState.ugraph evd.universes))
+      t u
 
 let test_conversion env d pb t u =
   try test_conversion_gen env d pb t u; true
   with _ -> false
 
+exception UniversesDiffer = UState.UniversesDiffer
+
 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 fold cstr sigma =
+    try Some (add_universe_constraints sigma cstr)
+    with Univ.UniverseInconsistency _ | UniversesDiffer -> None
+  in
+  match Universes.eq_constr_univs_infer (UState.ugraph evd.universes) fold t u evd with
+  | None -> evd, false
+  | Some evd -> evd, true
 
 let e_eq_constr_univs evdref t u =
   let evd, b = eq_constr_univs !evdref t u in
@@ -1403,7 +991,7 @@ let e_eq_constr_univs evdref t u =
 
 let emit_side_effects eff evd =
   { evd with effects = Safe_typing.concat_private eff evd.effects;
-	     universes = emit_universe_side_effects eff evd.universes }
+	     universes = UState.emit_side_effects eff evd.universes }
 
 let drop_side_effects evd =
   { evd with effects = Safe_typing.empty_private_constants; }
@@ -1419,7 +1007,7 @@ let declare_principal_goal evk evd =
   | None -> { evd with
     future_goals = evk::evd.future_goals;
     principal_future_goal=Some evk; }
-  | Some _ -> Errors.error "Only one main subgoal per instantiation."
+  | Some _ -> CErrors.error "Only one main subgoal per instantiation."
 
 let future_goals evd = evd.future_goals
 
@@ -1467,6 +1055,10 @@ let map_metas_fvalue f evd =
   in
   set_metas evd (Metamap.smartmap map evd.metas)
 
+let map_metas f evd =
+  let map cl = map_clb f cl in
+  set_metas evd (Metamap.smartmap map evd.metas)
+
 let meta_opt_fvalue evd mv =
   match Metamap.find mv evd.metas with
     | Clval(_,b,_) -> Some b
@@ -1520,39 +1112,6 @@ let meta_reassign mv (v, pb) evd =
 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 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
-    | _,[]  ->
-      explain_no_such_bound_variable evd id
-    | ([n],_|_,[n]) ->
-	n
-    | _  ->
-	errorlabstrm "Evd.meta_with_name"
-          (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 ?(with_univs = true) evd1 evd2 =
@@ -1576,18 +1135,6 @@ let retract_coercible_metas evd =
   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 ->
-      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)
@@ -1678,7 +1225,34 @@ type unsolvability_explanation = SeveralInstancesFound of int
 (**********************************************************)
 (* Pretty-printing *)
 
-let pr_existential_key sigma evk = str "?" ++ pr_id (evar_ident evk sigma)
+let pr_evar_suggested_name evk sigma =
+  let base_id evk' evi =
+  match evar_ident evk' sigma with
+  | Some id -> id
+  | None -> 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
+  in
+  let names = EvMap.mapi base_id sigma.undf_evars in
+  let id = EvMap.find evk names in
+  let fold evk' id' (seen, n) =
+    if seen then (seen, n)
+    else if Evar.equal evk evk' then (true, n)
+    else if Id.equal id id' then (seen, succ n)
+    else (seen, n)
+  in
+  let (_, n) = EvMap.fold fold names (false, 0) in
+  if n = 0 then id else Nameops.add_suffix id (string_of_int (pred n))
+
+let pr_existential_key sigma evk = match evar_ident evk sigma with
+| None ->
+  str "?" ++ pr_id (pr_evar_suggested_name evk sigma)
+| Some id ->
+  str "?" ++ pr_id id
 
 let pr_instance_status (sc,typ) =
   begin match sc with
@@ -1692,6 +1266,12 @@ let pr_instance_status (sc,typ) =
   | TypeProcessed -> str " [type is checked]"
   end
 
+let protect f x =
+  try f x
+  with e -> str "EXCEPTION: " ++ str (Printexc.to_string e)
+
+let print_constr a = protect print_constr a
+
 let pr_meta_map mmap =
   let pr_name = function
       Name id -> str"[" ++ pr_id id ++ str"]"
@@ -1710,13 +1290,14 @@ let pr_meta_map mmap =
   in
   prlist pr_meta_binding (metamap_to_list mmap)
 
-let pr_decl ((id,b,_),ok) =
-  match b with
+let pr_decl (decl,ok) =
+  let id = get_id decl in
+  match get_value decl with
   | None -> if ok then pr_id id else (str "{" ++ pr_id id ++ str "}")
   | Some c -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++
       print_constr c ++ str (if ok then ")" else "}")
 
-let rec pr_evar_source = function
+let pr_evar_source = function
   | Evar_kinds.QuestionMark _ -> str "underscore"
   | Evar_kinds.CasesType false -> str "pattern-matching return predicate"
   | Evar_kinds.CasesType true ->
@@ -1818,18 +1399,19 @@ let pr_evar_universe_context ctx =
   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 () ++
+       h 0 (Univ.pr_universe_context_set prl (evar_universe_context_set ctx)) ++ fnl () ++
      str"ALGEBRAIC UNIVERSES:"++brk(0,1)++
-     h 0 (Univ.LSet.pr prl ctx.uctx_univ_algebraic) ++ fnl() ++
+     h 0 (Univ.LSet.pr prl (UState.algebraics ctx)) ++ fnl() ++
      str"UNDEFINED UNIVERSES:"++brk(0,1)++
-       h 0 (Universes.pr_universe_opt_subst ctx.uctx_univ_variables) ++ fnl())
+       h 0 (Universes.pr_universe_opt_subst (UState.subst ctx)) ++ 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_named_decl (n, b, _) = pr_body (Name n) b in
-  let pr_rel_decl (n, b, _) = pr_body n b in
+  let pr_named_decl decl = pr_body (Name (get_id decl)) (get_value decl) in
+  let pr_rel_decl decl = let open Context.Rel.Declaration in
+                         pr_body (get_name decl) (get_value decl) in
   let nc = List.rev (named_context env) in
   let rc = List.rev (rel_context env) in
     str "[" ++ pr_sequence pr_named_decl nc ++ str "]" ++ spc () ++
@@ -1837,6 +1419,16 @@ let print_env_short env =
 
 let pr_evar_constraints pbs =
   let pr_evconstr (pbty, env, t1, t2) =
+    let env =
+      (** We currently allow evar instances to refer to anonymous de
+          Bruijn indices, so we protect the error printing code in this
+          case by giving names to every de Bruijn variable in the
+          rel_context of the conversion problem. MS: we should rather
+          stop depending on anonymous variables, they can be used to
+          indicate independency. Also, this depends on a strategy for
+          naming/renaming. *)
+      Namegen.make_all_name_different env
+    in
     print_env_short env ++ spc () ++ str "|-" ++ spc () ++
       print_constr_env env t1 ++ spc () ++
       str (match pbty with
@@ -1867,7 +1459,7 @@ let pr_evar_list sigma l =
     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 "}"
+       then str " {" ++  pr_existential_key sigma ev ++ str "}"
        else mt ()))
   in
   h 0 (prlist_with_sep fnl pr l)
diff --git a/pretyping/evd.mli b/engine/evd.mli
index 0b4f1853..86887f3d 100644
--- a/pretyping/evd.mli
+++ b/engine/evd.mli
@@ -10,10 +10,12 @@ open Util
 open Loc
 open Names
 open Term
-open Context
 open Environ
 
-(** {5 Existential variables and unification states}
+(** This file defines the pervasive unification state used everywhere in Coq
+    tactic engine. It is very low-level and most of the functions exported here
+    are irrelevant to the standard API user. Consider using {!Evarutil},
+    {!Sigma} or {!Proofview} instead.
 
     A unification state (of type [evar_map]) is primarily a finite mapping
     from existential variables to records containing the type of the evar
@@ -24,6 +26,8 @@ open Environ
     It also contains conversion constraints, debugging information and
     information about meta variables. *)
 
+(** {5 Existential variables and unification states} *)
+
 (** {6 Evars} *)
 
 type evar = existential_key
@@ -94,19 +98,20 @@ type evar_info = {
   (** Optional content of the evar. *)
   evar_filter : Filter.t;
   (** Boolean mask over {!evar_hyps}. Should have the same length.
-      TODO: document me more. *)
+      When filtered out, the corresponding variable is not allowed to occur
+      in the solution *)
   evar_source : Evar_kinds.t located;
   (** Information about the evar. *)
   evar_candidates : constr list option;
-  (** TODO: document this *)
+  (** List of possible solutions when known that it is a finite list *)
   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
-val evar_context : evar_info -> named_context
-val evar_filtered_context : evar_info -> named_context
+val evar_context : evar_info -> Context.Named.t
+val evar_filtered_context : evar_info -> Context.Named.t
 val evar_hyps : evar_info -> named_context_val
 val evar_filtered_hyps : evar_info -> named_context_val
 val evar_body : evar_info -> evar_body
@@ -119,7 +124,7 @@ val map_evar_info : (constr -> constr) -> evar_info -> evar_info
 
 (** {6 Unification state} **)
 
-type evar_universe_context
+type evar_universe_context = UState.t
 (** The universe context associated to an evar map *)
 
 type evar_map
@@ -143,6 +148,10 @@ val has_undefined : evar_map -> bool
 (** [has_undefined sigma] is [true] if and only if
     there are uninstantiated evars in [sigma]. *)
 
+val new_evar : evar_map ->
+  ?naming:Misctypes.intro_pattern_naming_expr -> evar_info -> evar_map * evar
+(** Creates a fresh evar mapping to the given information. *)
+
 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]. *)
@@ -219,7 +228,7 @@ val existential_opt_value : evar_map -> existential -> constr option
 (** Same as {!existential_value} but returns an option instead of raising an
     exception. *)
 
-val evar_instance_array : (named_declaration -> 'a -> bool) -> evar_info ->
+val evar_instance_array : (Context.Named.Declaration.t -> 'a -> bool) -> evar_info ->
   'a array -> (Id.t * 'a) list
 
 val instantiate_evar_array : evar_info -> constr -> constr array -> constr
@@ -230,14 +239,8 @@ val evars_reset_evd  : ?with_conv_pbs:bool -> ?with_univs:bool ->
 
 (** {6 Misc} *)
 
-val evar_declare :
-  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
+val restrict : evar -> Filter.t -> ?candidates:constr list ->
+  evar_map -> evar_map * evar
 (** Restrict an undefined evar into a new evar by filtering context and
     possibly limiting the instances to a set of candidates *)
 
@@ -249,7 +252,7 @@ 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 evar_ident : existential_key -> evar_map -> Id.t option
 
 val rename : existential_key -> Id.t -> evar_map -> evar_map
 
@@ -346,7 +349,6 @@ val on_sig : 'a sigma -> (evar_map -> evar_map * 'b) -> 'a sigma * 'b
 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
@@ -425,7 +427,7 @@ val evar_list : constr -> existential list
 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_named_context : Context.Named.t -> Evar.Set.t
 
 val evars_of_filtered_evar_info : evar_info -> Evar.Set.t
 
@@ -442,7 +444,6 @@ val meta_opt_fvalue : evar_map -> metavariable -> (constr freelisted * instance_
 val meta_type      : evar_map -> metavariable -> types
 val meta_ftype     : evar_map -> metavariable -> types freelisted
 val meta_name      : evar_map -> metavariable -> Name.t
-val meta_with_name : evar_map -> Id.t -> metavariable
 val meta_declare   :
   metavariable -> types -> ?name:Name.t -> evar_map -> evar_map
 val meta_assign    : metavariable -> constr * instance_status -> evar_map -> evar_map
@@ -455,20 +456,30 @@ val meta_merge : ?with_univs:bool -> evar_map -> evar_map -> evar_map
 
 val undefined_metas : evar_map -> metavariable list
 val map_metas_fvalue : (constr -> constr) -> evar_map -> evar_map
+val map_metas : (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_evars : metabinding list * ('a * existential * constr) list -> constr -> constr option
 
 (** {5 FIXME: Nothing to do here} *)
 
 (*********************************************************
    Sort/universe variables *)
 
-(** Rigid or flexible universe variables *)
+(** Rigid or flexible universe variables.
 
-type rigid = 
+   [UnivRigid] variables are user-provided or come from an explicit
+   [Type] in the source, we do not minimize them or unify them eagerly.
+
+   [UnivFlexible alg] variables are fresh universe variables of
+   polymorphic constants or generated during refinement, sometimes in
+   algebraic position (i.e. not appearing in the term at the moment of
+   creation). They are the candidates for minimization (if alg, to an
+   algebraic universe) and unified eagerly in the first-order
+   unification heurstic.  *)
+
+type rigid = UState.rigid =
   | UnivRigid
   | UnivFlexible of bool (** Is substitution by an algebraic ok? *)
 
@@ -478,7 +489,7 @@ val univ_flexible_alg : rigid
 
 type 'a in_evar_universe_context = 'a * evar_universe_context
 
-val evar_universe_context_set : Univ.universe_context -> evar_universe_context -> Univ.universe_context_set
+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
@@ -486,6 +497,8 @@ 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
+val constrain_variables : Univ.LSet.t -> evar_universe_context -> Univ.constraints
+
 
 val evar_universe_context_of_binders :
   Universes.universe_binders -> evar_universe_context
@@ -496,8 +509,6 @@ val restrict_universe_context : evar_map -> Univ.universe_set -> evar_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
 
@@ -508,18 +519,19 @@ val normalize_evar_universe_context_variables : evar_universe_context ->
 val normalize_evar_universe_context : evar_universe_context -> 
   evar_universe_context
 
-val new_univ_level_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe_level
-val new_univ_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe
-val new_sort_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * sorts
+val new_univ_level_variable : ?loc:Loc.t -> ?name:string -> rigid -> evar_map -> evar_map * Univ.universe_level
+val new_univ_variable : ?loc:Loc.t -> ?name:string -> rigid -> evar_map -> evar_map * Univ.universe
+val new_sort_variable : ?loc:Loc.t -> ?name:string -> rigid -> evar_map -> evar_map * sorts
+
 val add_global_univ : evar_map -> Univ.Level.t -> evar_map
-											   
+
+val universe_rigidity : evar_map -> Univ.Level.t -> rigid
 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 whd_sort_variable : evar_map -> constr -> constr
 (* 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
@@ -540,16 +552,16 @@ val universe_context_set : evar_map -> Univ.universe_context_set
 val universe_context : ?names:(Id.t located) list -> evar_map ->
 		       (Id.t * Univ.Level.t) list * Univ.universe_context
 val universe_subst : evar_map -> Universes.universe_opt_subst
-val universes : evar_map -> Univ.universes
+val universes : evar_map -> UGraph.t
 
 
 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 : ?sideff:bool -> rigid -> evar_map -> Univ.universe_context_set -> evar_map
+val merge_context_set : ?loc:Loc.t -> ?sideff:bool -> 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 with_context_set : ?loc:Loc.t -> 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
@@ -564,13 +576,13 @@ val update_sigma_env : evar_map -> env -> 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_sort_in_family : ?loc:Loc.t -> ?rigid:rigid -> env -> evar_map -> sorts_family -> evar_map * sorts
+val fresh_constant_instance : ?loc:Loc.t -> env -> evar_map -> constant -> evar_map * pconstant
+val fresh_inductive_instance : ?loc:Loc.t -> env -> evar_map -> inductive -> evar_map * pinductive
+val fresh_constructor_instance : ?loc:Loc.t -> 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
+val fresh_global : ?loc:Loc.t -> ?rigid:rigid -> ?names:Univ.Instance.t -> env ->
+  evar_map -> Globnames.global_reference -> evar_map * constr
 
 (********************************************************************
   Conversion w.r.t. an evar map, not unifying universes. See 
@@ -602,6 +614,8 @@ type unsolvability_explanation = SeveralInstancesFound of int
 
 val pr_existential_key : evar_map -> evar -> Pp.std_ppcmds
 
+val pr_evar_suggested_name : existential_key -> evar_map -> Id.t
+
 (** {5 Debug pretty-printers} *)
 
 val pr_evar_info : evar_info -> Pp.std_ppcmds
@@ -618,4 +632,6 @@ val pr_evd_level : evar_map -> Univ.Level.t -> Pp.std_ppcmds
 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
+(** {5 Summary names} *)
+
+val evar_counter_summary_name : string
diff --git a/tactics/ftactic.ml b/engine/ftactic.ml
index 8e42dcba..aeaaea7e 100644
--- a/tactics/ftactic.ml
+++ b/engine/ftactic.ml
@@ -29,24 +29,55 @@ let bind (type a) (type b) (m : a t) (f : a -> b t) : b t = m >>= 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.Goal.goals >>= fun goals ->
+    let ans = List.map (fun g -> (g,x)) goals in
     Proofview.tclUNIT ans
-  | Depends l -> Proofview.tclUNIT l
+  | Depends l ->
+    Proofview.Goal.goals >>= fun goals ->
+    Proofview.tclUNIT (List.combine goals l)
+  in
+  (* After the tactic has run, some goals which were previously
+     produced may have been solved by side effects. The values
+     attached to such goals must be discarded, otherwise the list of
+     result would not have the same length as the list of focused
+     goals, which is an invariant of the [Ftactic] module. It is the
+     reason why a goal is attached to each result above. *)
+  let filter (g,x) =
+    g >>= fun g ->
+    Proofview.Goal.unsolved g >>= function
+    | true -> Proofview.tclUNIT (Some x)
+    | false -> Proofview.tclUNIT None
   in
   Proofview.tclDISPATCHL (List.map f l) >>= fun l ->
-  Proofview.tclUNIT (Depends (List.concat l))
+  Proofview.Monad.List.map_filter filter (List.concat l) >>= fun filtered ->
+  Proofview.tclUNIT (Depends filtered)
+
+let goals = Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l)
+let set_sigma r =
+  let Sigma.Sigma (ans, sigma, _) = r in
+  Proofview.Unsafe.tclEVARS (Sigma.to_evar_map sigma) >>= fun () -> ans
 
 let nf_enter f =
-  bind (Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l))
+  bind goals
+    (fun gl ->
+      gl >>= fun gl ->
+      Proofview.Goal.normalize gl >>= fun nfgl ->
+      Proofview.V82.wrap_exceptions (fun () -> f.enter nfgl))
+
+let nf_s_enter f =
+  bind goals
     (fun gl ->
       gl >>= fun gl ->
       Proofview.Goal.normalize gl >>= fun nfgl ->
-      Proofview.V82.wrap_exceptions (fun () -> f nfgl))
+      Proofview.V82.wrap_exceptions (fun () -> set_sigma (f.s_enter 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))
+  bind goals
+    (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f.enter gl))
+
+let s_enter f =
+  bind goals
+    (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> set_sigma (f.s_enter gl)))
 
 let with_env t =
   t >>= function
@@ -83,4 +114,8 @@ end
 module Ftac = Monad.Make(Self)
 module List = Ftac.List
 
-let debug_prompt = Tactic_debug.debug_prompt
+module Notations =
+struct
+  let (>>=) = bind
+  let (<*>) = fun m n -> bind m (fun () -> n)
+end
diff --git a/tactics/ftactic.mli b/engine/ftactic.mli
index 3f4da2a8..5db37319 100644
--- a/tactics/ftactic.mli
+++ b/engine/ftactic.mli
@@ -6,7 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(** Potentially focussing tactics *)
+open Proofview.Notations
+
+(** This module defines potentially focussing tactics. They are used by Ltac to
+    emulate the historical behaviour of always-focussed tactics while still
+    allowing to remain global when the goal is not needed. *)
 
 type +'a focus
 
@@ -37,13 +41,20 @@ val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic
 
 (** {5 Focussing} *)
 
-val nf_enter : ([ `NF ] Proofview.Goal.t -> 'a t) -> 'a t
+val nf_enter : ([ `NF ], 'a t) enter -> 'a t
 (** Enter a goal. The resulting tactic is focussed. *)
 
-val enter : ([ `LZ ] Proofview.Goal.t -> 'a t) -> 'a t
+val enter : ([ `LZ ], 'a t) enter -> 'a t
 (** Enter a goal, without evar normalization. The resulting tactic is
     focussed. *)
 
+val s_enter : ([ `LZ ], 'a t) s_enter -> 'a t
+(** Enter a goal and put back an evarmap. The resulting tactic is focussed. *)
+
+val nf_s_enter : ([ `NF ], 'a t) s_enter -> 'a t
+(** Enter a goal, without evar normalization and put back an evarmap. 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
@@ -61,7 +72,10 @@ val (<*>) : unit t -> 'a t -> 'a t
 
 module List : Monad.ListS with type 'a t := 'a t
 
-(** {5 Debug} *)
+(** {5 Notations} *)
 
-val debug_prompt :
-  int -> Tacexpr.glob_tactic_expr -> (Tactic_debug.debug_info -> 'a t) -> 'a t
+module Notations :
+sig
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+  val (<*>) : unit t -> 'a t -> 'a t
+end
diff --git a/engine/geninterp.ml b/engine/geninterp.ml
new file mode 100644
index 00000000..cfca95d3
--- /dev/null
+++ b/engine/geninterp.ml
@@ -0,0 +1,98 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \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)
+
+(** Dynamic toplevel values *)
+
+module ValT = Dyn.Make(struct end)
+
+module Val =
+struct
+
+  type 'a typ = 'a ValT.tag
+
+  type _ tag =
+  | Base : 'a typ -> 'a tag
+  | List : 'a tag -> 'a list tag
+  | Opt : 'a tag -> 'a option tag
+  | Pair : 'a tag * 'b tag -> ('a * 'b) tag
+
+  type t = Dyn : 'a typ * 'a -> t
+
+  let eq = ValT.eq
+  let repr = ValT.repr
+  let create = ValT.create
+
+  let pr : type a. a typ -> Pp.std_ppcmds = fun t -> Pp.str (repr t)
+
+  let typ_list = ValT.create "list"
+  let typ_opt = ValT.create "option"
+  let typ_pair = ValT.create "pair"
+
+  let rec inject : type a. a tag -> a -> t = fun tag x -> match tag with
+  | Base t -> Dyn (t, x)
+  | List tag -> Dyn (typ_list, List.map (fun x -> inject tag x) x)
+  | Opt tag -> Dyn (typ_opt, Option.map (fun x -> inject tag x) x)
+  | Pair (tag1, tag2) ->
+    Dyn (typ_pair, (inject tag1 (fst x), inject tag2 (snd x)))
+
+end
+
+module ValReprObj =
+struct
+  type ('raw, 'glb, 'top) obj = 'top Val.tag
+  let name = "valrepr"
+  let default _ = None
+end
+
+module ValRepr = Register(ValReprObj)
+
+let rec val_tag : type a b c. (a, b, c) genarg_type -> c Val.tag = function
+| ListArg t -> Val.List (val_tag t)
+| OptArg t -> Val.Opt (val_tag t)
+| PairArg (t1, t2) -> Val.Pair (val_tag t1, val_tag t2)
+| ExtraArg s -> ValRepr.obj (ExtraArg s)
+
+let val_tag = function Topwit t -> val_tag t
+
+let register_val0 wit tag =
+  let tag = match tag with
+  | None ->
+    let name = match wit with
+    | ExtraArg s -> ArgT.repr s
+    | _ -> assert false
+    in
+    Val.Base (Val.create name)
+  | Some tag -> tag
+  in
+  ValRepr.register0 wit tag
+
+(** Interpretation functions *)
+
+type interp_sign = {
+  lfun : Val.t Id.Map.t;
+  extra : TacStore.t }
+
+type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t
+
+module InterpObj =
+struct
+  type ('raw, 'glb, 'top) obj = ('glb, Val.t) interp_fun
+  let name = "interp"
+  let default _ = None
+end
+
+module Interp = Register(InterpObj)
+
+let interp = Interp.obj
+
+let register_interp0 = Interp.register0
diff --git a/engine/geninterp.mli b/engine/geninterp.mli
new file mode 100644
index 00000000..b70671a2
--- /dev/null
+++ b/engine/geninterp.mli
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Interpretation functions for generic arguments and interpreted Ltac
+    values. *)
+
+open Names
+open Genarg
+
+(** {6 Dynamic toplevel values} *)
+
+module Val :
+sig
+  type 'a typ
+
+  val create : string -> 'a typ
+
+  type _ tag =
+  | Base : 'a typ -> 'a tag
+  | List : 'a tag -> 'a list tag
+  | Opt : 'a tag -> 'a option tag
+  | Pair : 'a tag * 'b tag -> ('a * 'b) tag
+
+  type t = Dyn : 'a typ * 'a -> t
+
+  val eq : 'a typ -> 'b typ -> ('a, 'b) CSig.eq option
+  val repr : 'a typ -> string
+  val pr : 'a typ -> Pp.std_ppcmds
+
+  val typ_list : t list typ
+  val typ_opt : t option typ
+  val typ_pair : (t * t) typ
+
+  val inject : 'a tag -> 'a -> t
+
+end
+(** Dynamic types for toplevel values. While the generic types permit to relate
+    objects at various levels of interpretation, toplevel values are wearing
+    their own type regardless of where they came from. This allows to use the
+    same runtime representation for several generic types. *)
+
+val val_tag : 'a typed_abstract_argument_type -> 'a Val.tag
+(** Retrieve the dynamic type associated to a toplevel genarg. *)
+
+val register_val0 : ('raw, 'glb, 'top) genarg_type -> 'top Val.tag option -> unit
+(** Register the representation of a generic argument. If no tag is given as
+    argument, a new fresh tag with the same name as the argument is associated
+    to the generic type. *)
+
+(** {6 Interpretation functions} *)
+
+module TacStore : Store.S
+
+type interp_sign = {
+  lfun : Val.t Id.Map.t;
+  extra : TacStore.t }
+
+type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t
+
+val interp : ('raw, 'glb, 'top) genarg_type -> ('glb, Val.t) interp_fun
+
+val register_interp0 :
+  ('raw, 'glb, 'top) genarg_type -> ('glb, Val.t) interp_fun -> unit
diff --git a/proofs/logic_monad.ml b/engine/logic_monad.ml
index 68efa71e..17ff898b 100644
--- a/proofs/logic_monad.ml
+++ b/engine/logic_monad.ml
@@ -33,11 +33,11 @@ exception Timeout
     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
+let _ = CErrors.register_handler begin function
+  | Timeout -> CErrors.errorlabstrm "Some timeout function" (Pp.str"Timeout!")
+  | Exception e -> CErrors.print e
+  | TacticFailure e -> CErrors.print e
+  | _ -> Pervasives.raise CErrors.Unhandled
 end
 
 (** {6 Non-logical layer} *)
@@ -86,11 +86,11 @@ struct
   let catch = fun s h -> ();
     fun () -> try s ()
       with Exception e as src ->
-        let (src, info) = Errors.push src in
+        let (src, info) = CErrors.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 (e, info) = CErrors.push e in raise ~info e ()
 
   let print_char = fun c -> (); fun () -> print_char c
 
@@ -99,20 +99,20 @@ struct
 
   let make f = (); fun () ->
     try f ()
-    with e when Errors.noncritical e ->
-      let (e, info) = Errors.push e in
+    with e when CErrors.noncritical e ->
+      let (e, info) = CErrors.push e in
       Util.iraise (Exception e, info)
 
   (** Use the current logger. The buffer is also flushed. *)
-  let print_debug s = make (fun _ -> Pp.msg_info s;Pp.pp_flush ())
-  let print_info s =  make (fun _ -> Pp.msg_info s;Pp.pp_flush ())
-  let print_warning s =  make (fun _ -> Pp.msg_warning s;Pp.pp_flush ())
-  let print_error s =  make (fun _ -> Pp.msg_error s;Pp.pp_flush ())
-  let print_notice s = make (fun _ -> Pp.msg_notice s;Pp.pp_flush ())
+  let print_debug   s = make (fun _ -> Feedback.msg_info s)
+  let print_info    s = make (fun _ -> Feedback.msg_info s)
+  let print_warning s = make (fun _ -> Feedback.msg_warning s)
+  let print_error   s = make (fun _ -> Feedback.msg_error s)
+  let print_notice  s = make (fun _ -> Feedback.msg_notice s)
 
   let run = fun x ->
     try x () with Exception e as src ->
-      let (src, info) = Errors.push src in
+      let (src, info) = CErrors.push src in
       Util.iraise (e, info)
 end
 
@@ -138,46 +138,13 @@ end
 
 (** 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
+type ('a, 'b, 'e) list_view =
+  | Nil of 'e
+  | Cons of 'a * ('e -> '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) =
+module BackState =
 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
@@ -208,32 +175,25 @@ struct
       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. state -> (rich_exn -> 'r NonLogical.t) ->
-      ('a -> state -> (rich_exn -> 'r NonLogical.t) -> 'r NonLogical.t) ->
-      'r NonLogical.t }
-
-  include Monad.Make(struct
 
-    type 'a t = 'a iolist
+  type ('a, 'i, 'o, 'e) t =
+      { iolist : 'r. 'i -> ('e -> 'r NonLogical.t) ->
+                     ('a -> 'o -> ('e -> 'r NonLogical.t) -> 'r NonLogical.t) ->
+                     'r NonLogical.t }
 
-    let return x =
-      { iolist = fun s nil cons -> cons x s nil }
+  let return x =
+    { iolist = fun s nil cons -> cons x s nil }
 
-    let (>>=) m f =
-      { iolist = fun s nil cons ->
-        m.iolist s nil (fun x s next -> (f x).iolist s next cons) }
+  let (>>=) m f =
+    { iolist = fun s nil cons ->
+      m.iolist s nil (fun x s next -> (f x).iolist s next cons) }
 
-    let (>>) m f =
-      { iolist = fun s nil cons ->
-        m.iolist s nil (fun () s next -> f.iolist s next cons) }
+  let (>>) m f =
+    { iolist = fun s nil cons ->
+      m.iolist s nil (fun () s next -> f.iolist s next cons) }
 
-    let map f m =
-      { iolist = fun s nil cons -> m.iolist s nil (fun x s next -> cons (f x) s next) }
-
-  end)
+  let map f m =
+    { iolist = fun s nil cons -> m.iolist s nil (fun x s next -> cons (f x) s next) }
 
   let zero e =
     { iolist = fun _ nil cons -> nil e }
@@ -250,27 +210,21 @@ struct
   (** State related *)
 
   let get =
-    { iolist = fun s nil cons -> cons s.sstate s nil }
+    { iolist = fun s nil cons -> cons s s nil }
 
-  let set (sstate : P.s) =
-    { iolist = fun s nil cons -> cons () { s with sstate } nil }
+  let set s =
+    { iolist = fun _ nil cons -> cons () s nil }
 
-  let modify (f : P.s -> P.s) =
-    { iolist = fun s nil cons -> cons () { s with sstate = f s.sstate } nil }
+  let modify f =
+    { iolist = fun s nil cons -> cons () (f s) nil }
 
-  let current =
-    { iolist = fun s nil cons -> cons s.rstate s nil }
+  (** Exception manipulation *)
 
-  let local e m =
+  let interleave src dst m =
     { iolist = fun s nil cons ->
-      m.iolist { s with rstate = e } nil
-        (fun x s' next -> cons x {s' with rstate = s.rstate} next) }
-
-  let put w =
-    { iolist = fun s nil cons -> cons () { s with wstate = P.wprod s.wstate w } nil }
-
-  let update (f : P.u -> P.u) =
-    { iolist = fun s nil cons -> cons () { s with ustate = f s.ustate } nil }
+      m.iolist s (fun e1 -> nil (src e1))
+        (fun x s next -> cons x s (fun e2 -> next (dst e2)))
+    }
 
   (** List observation *)
 
@@ -284,9 +238,9 @@ struct
 
   (** 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
+  type ('a, 'e) reified = ('a, ('a, 'e) reified, 'e) list_view NonLogical.t
 
-  let rec reflect (m : ('a * state) reified) : 'a iolist =
+  let rec reflect (m : ('a * 'o, 'e) reified) =
     { iolist = fun s0 nil cons ->
       let next = function
       | Nil e -> nil e
@@ -295,7 +249,7 @@ struct
       NonLogical.(m >>= next)
     }
 
-  let split m : ('a, rich_exn -> 'a t) list_view t =
+  let split m : ((_, _, _) list_view, _, _, _) t =
     let rnil e = NonLogical.return (Nil e) in
     let rcons p s l = NonLogical.return (Cons ((p, s), l)) in
     { iolist = fun s nil cons ->
@@ -307,6 +261,116 @@ struct
         cons (Cons (x, l)) s nil
       end }
 
+  let run m s =
+    let rnil e = NonLogical.return (Nil e) in
+    let rcons x s l =
+      let p = (x, s) in
+      NonLogical.return (Cons (p, l))
+    in
+    m.iolist s rnil rcons
+
+  let repr x = x
+end
+
+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
+
+  module Unsafe =
+  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;
+    }
+
+    let make m = m
+    let repr m = m
+  end
+
+  open Unsafe
+
+  type state = Unsafe.state
+
+  type iexn = Exninfo.iexn
+
+  type 'a reified = ('a, iexn) BackState.reified
+
+  (** Inherited from Backstate *)
+
+  open BackState
+
+  include Monad.Make(struct
+    type 'a t = ('a, state, state, iexn) BackState.t
+    let return = BackState.return
+    let (>>=) = BackState.(>>=)
+    let (>>) = BackState.(>>)
+    let map = BackState.map
+  end)
+
+  let zero = BackState.zero
+  let plus = BackState.plus
+  let ignore = BackState.ignore
+  let lift = BackState.lift
+  let once = BackState.once
+  let break = BackState.break
+  let split = BackState.split
+  let repr = BackState.repr
+
+  (** State related. We specialize them here to ensure soundness (for reader and
+      writer) and efficiency. *)
+
+  let get =
+    { iolist = fun s nil cons -> cons s.sstate s nil }
+
+  let set (sstate : P.s) =
+    { iolist = fun s nil cons -> cons () { s with sstate } nil }
+
+  let modify (f : P.s -> P.s) =
+    { iolist = fun s nil cons -> cons () { s with sstate = f s.sstate } nil }
+
+  let current =
+    { iolist = fun s nil cons -> cons s.rstate s nil }
+
+  let local e m =
+    { iolist = fun s nil cons ->
+      m.iolist { s with rstate = e } nil
+        (fun x s' next -> cons x {s' with rstate = s.rstate} next) }
+
+  let put w =
+    { iolist = fun s nil cons -> cons () { s with wstate = P.wprod s.wstate w } nil }
+
+  let update (f : P.u -> P.u) =
+    { iolist = fun s nil cons -> cons () { s with ustate = f s.ustate } nil }
+
+  (** Monadic run is specialized to handle reader / writer *)
+
   let run m r s =
     let s = { wstate = P.wunit; ustate = P.uunit; rstate = r; sstate = s } in
     let rnil e = NonLogical.return (Nil e) in
@@ -316,6 +380,4 @@ struct
     in
     m.iolist s rnil rcons
 
-  let repr x = x
-
  end
diff --git a/proofs/logic_monad.mli b/engine/logic_monad.mli
index 96655d53..dd122cca 100644
--- a/proofs/logic_monad.mli
+++ b/engine/logic_monad.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(** This file defines the low-level monadic operations used by the
+(** This file implements 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)
@@ -102,9 +102,48 @@ end
 
 (** 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
+type ('a, 'b, 'e) list_view =
+| Nil of 'e
+| Cons of 'a * ('e -> 'b)
+
+module BackState : sig
+
+  type (+'a, -'i, +'o, 'e) t
+  val return : 'a -> ('a, 's, 's, 'e) t
+  val (>>=) : ('a, 'i, 'm, 'e) t -> ('a -> ('b, 'm, 'o, 'e) t) -> ('b, 'i, 'o, 'e) t
+  val (>>) : (unit, 'i, 'm, 'e) t -> ('b, 'm, 'o, 'e) t -> ('b, 'i, 'o, 'e) t
+  val map : ('a -> 'b) -> ('a, 'i, 'o, 'e) t -> ('b, 'i, 'o, 'e) t
+
+  val ignore : ('a, 'i, 'o, 'e) t -> (unit, 'i, 'o, 'e) t
+
+  val set : 'o -> (unit, 'i, 'o, 'e) t
+  val get : ('s, 's, 's, 'e) t
+  val modify : ('i -> 'o) -> (unit, 'i, 'o, 'e) t
+
+  val interleave : ('e1 -> 'e2) -> ('e2 -> 'e1) -> ('a, 'i, 'o, 'e1) t ->
+    ('a, 'i, 'o, 'e2) t
+  (** [interleave src dst m] adapts the exceptional content of the monad
+      according to the functions [src] and [dst]. To ensure a meaningful result,
+      those functions must form a retraction, i.e. [dst (src e1) = e1] for all
+      [e1]. This is typically the case when the type ['e1] is [unit]. *)
+
+  val zero : 'e -> ('a, 'i, 'o, 'e) t
+  val plus : ('a, 'i, 'o, 'e) t -> ('e -> ('a, 'i, 'o, 'e) t) -> ('a, 'i, 'o, 'e) t
+
+  val split : ('a, 's, 's, 'e) t ->
+    (('a, ('a, 'i, 's, 'e) t, 'e) list_view, 's, 's, 'e) t
+
+  val once : ('a, 'i, 'o, 'e) t -> ('a, 'i, 'o, 'e) t
+  val break : ('e -> 'e option) -> ('a, 'i, 'o, 'e) t -> ('a, 'i, 'o, 'e) t
+  val lift : 'a NonLogical.t -> ('a, 's, 's, 'e) t
+
+  type ('a, 'e) reified
+
+  val repr : ('a, 'e) reified -> ('a, ('a, 'e) reified, 'e) list_view NonLogical.t
+
+  val run : ('a, 'i, 'o, 'e) t -> 'i -> ('a * 'o, 'e) reified
+
+end
 
 (** The monad is parametrised in the types of state, environment and
     writer. *)
@@ -147,16 +186,30 @@ module Logical (P:Param) : sig
 
   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 split : 'a t -> ('a, 'a t, Exninfo.iexn) 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
+  type 'a reified = ('a, Exninfo.iexn) BackState.reified
 
-  val repr : 'a reified -> ('a, Exninfo.iexn -> 'a reified) list_view NonLogical.t
+  val repr : 'a reified -> ('a, 'a reified, Exninfo.iexn) list_view NonLogical.t
 
   val run : 'a t -> P.e -> P.s -> ('a * P.s * P.w * P.u) reified
 
+  module Unsafe :
+  sig
+    type state = {
+      rstate : P.e;
+      ustate : P.u;
+      wstate : P.w;
+      sstate : P.s;
+    }
+
+    val make : ('a, state, state, Exninfo.iexn) BackState.t -> 'a t
+    val repr : 'a t -> ('a, state, state, Exninfo.iexn) BackState.t
+
+  end
+
 end
diff --git a/pretyping/namegen.ml b/engine/namegen.ml
index fc3f0cc7..84eb9868 100644
--- a/pretyping/namegen.ml
+++ b/engine/namegen.ml
@@ -22,6 +22,7 @@ open Libnames
 open Globnames
 open Environ
 open Termops
+open Context.Rel.Declaration
 
 (**********************************************************************)
 (* Conventional names *)
@@ -113,7 +114,7 @@ let hdchar env c =
     | Rel n ->
 	(if n<=k then "p" (* the initial term is flexible product/function *)
 	 else
-	   try match Environ.lookup_rel (n-k) env with
+	   try match Environ.lookup_rel (n-k) env |> to_tuple with
 	     | (Name id,_,_)   -> lowercase_first_char id
 	     | (Anonymous,_,t) -> hdrec 0 (lift (n-k) t)
 	   with Not_found -> "y")
@@ -142,10 +143,9 @@ let prod_name = mkProd_name
 let prod_create   env (a,b) = mkProd (named_hd env a Anonymous, a, b)
 let lambda_create env (a,b) =  mkLambda (named_hd env a Anonymous, a, b)
 
-let name_assumption env (na,c,t) =
-  match c with
-    | None      -> (named_hd env t na, None, t)
-    | Some body -> (named_hd env body na, c, t)
+let name_assumption env = function
+    | LocalAssum (na,t) -> LocalAssum (named_hd env t na, t)
+    | LocalDef (na,c,t) -> LocalDef (named_hd env c na, c, t)
 
 let name_context env hyps =
   snd
@@ -184,28 +184,44 @@ 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
+let visible_ids (nenv, c) =
+  let accu = ref (Refset_env.empty, Int.Set.empty, Id.Set.empty) in
+  let rec visible_ids n c = match kind_of_term c with
+  | Const _ | Ind _ | Construct _ | Var _ ->
+    let (gseen, vseen, ids) = !accu in
+    let g = global_of_constr c in
+    if not (Refset_env.mem g gseen) then
+      begin
+      try
+      let gseen = Refset_env.add g gseen in
+      let short = shortest_qualid_of_global Id.Set.empty g in
+      let dir, id = repr_qualid short in
+      let ids = if DirPath.is_empty dir then Id.Set.add id ids else ids in
+      accu := (gseen, vseen, ids)
+      with Not_found when !Flags.in_debugger || !Flags.in_toplevel -> ()
+      end
+  | Rel p ->
+    let (gseen, vseen, ids) = !accu in
+    if p > n && not (Int.Set.mem p vseen) then
+      let vseen = Int.Set.add p vseen in
+      let name =
+        try Some (lookup_name_of_rel (p - n) nenv)
+        with Not_found ->
+          (* Unbound index: may happen in debug and actually also
+             while computing temporary implicit arguments of an
+             inductive type *)
+          None
+      in
+      let ids = match name with
+      | Some (Name id) -> Id.Set.add id ids
+      | _ -> ids
+      in
+      accu := (gseen, vseen, ids)
+  | _ -> Constr.iter_with_binders succ visible_ids n c
   in
-  try occur 1 c; false
-  with Occur -> true
-    | Not_found -> false (* Happens when a global is not in the env *)
+  let () = visible_ids 1 c in
+  let (_, _, ids) = !accu in
+  ids
 
 (* Now, there are different renaming strategies... *)
 
@@ -213,8 +229,9 @@ let visibly_occur_id id (nenv,c) =
 
 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 visible = visible_ids env_t in
   let bad id = to_avoid id avoid || is_constructor id
-                                 || visibly_occur_id id env_t in
+                                 || Id.Set.mem id visible in
   next_ident_away_from id bad
 
 (* 2- Looks for a fresh name for introduction in goal *)
@@ -277,11 +294,12 @@ 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
   process_rel_context
-    (fun (na,c,t) newenv ->
+    (fun decl newenv ->
+       let (na,_,t) = to_tuple decl in
        let na = named_hd newenv t na in
        let id = next_name_away na !avoid in
        avoid := id::!avoid;
-       push_rel (Name id,c,t) newenv)
+       push_rel (set_name (Name id) decl) newenv)
     env
 
 (* 5- Looks for next fresh name outside a list; avoids also to use names that
@@ -290,7 +308,8 @@ let make_all_name_different env =
    subscript *)
 
 let next_ident_away_for_default_printing env_t id avoid =
-  let bad id = to_avoid id avoid || visibly_occur_id id env_t in
+  let visible = visible_ids env_t in
+  let bad id = to_avoid id avoid || Id.Set.mem id visible in
   next_ident_away_from id bad
 
 let next_name_away_for_default_printing env_t na avoid =
diff --git a/pretyping/namegen.mli b/engine/namegen.mli
index 6751bd3c..97c7c34a 100644
--- a/pretyping/namegen.mli
+++ b/engine/namegen.mli
@@ -6,9 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(** This file features facilities to generate fresh names. *)
+
 open Names
 open Term
-open Context
 open Environ
 
 (*********************************************************************
@@ -39,13 +40,13 @@ val lambda_name : env -> Name.t * types * constr -> constr
 
 val prod_create : env -> types * types -> constr
 val lambda_create : env -> types * constr -> constr
-val name_assumption : env -> rel_declaration -> rel_declaration
-val name_context : env -> rel_context -> rel_context
+val name_assumption : env -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t
+val name_context : env -> Context.Rel.t -> Context.Rel.t
 
-val mkProd_or_LetIn_name : env -> types -> rel_declaration -> types
-val mkLambda_or_LetIn_name : env -> constr -> rel_declaration -> constr
-val it_mkProd_or_LetIn_name   : env -> types -> rel_context -> types
-val it_mkLambda_or_LetIn_name : env -> constr -> rel_context -> constr
+val mkProd_or_LetIn_name : env -> types -> Context.Rel.Declaration.t -> types
+val mkLambda_or_LetIn_name : env -> constr -> Context.Rel.Declaration.t -> constr
+val it_mkProd_or_LetIn_name   : env -> types -> Context.Rel.t -> types
+val it_mkLambda_or_LetIn_name : env -> constr -> Context.Rel.t -> constr
 
 (*********************************************************************
    Fresh names *)
@@ -63,9 +64,6 @@ val next_ident_away_in_goal : Id.t -> Id.t list -> Id.t
    but tolerate overwriting section variables, as in goals *)
 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 : (Termops.names_context * constr) -> Name.t -> Id.t list -> Id.t
-
 (** Default is [default_non_dependent_ident] *)
 val next_name_away  : Name.t -> Id.t list -> Id.t
 
diff --git a/proofs/proofview.ml b/engine/proofview.ml
index a6d9735f..c0187976 100644
--- a/proofs/proofview.ml
+++ b/engine/proofview.ml
@@ -16,6 +16,8 @@
 open Pp
 open Util
 open Proofview_monad
+open Sigma.Notations
+open Context.Named.Declaration
 
 (** Main state of tactics *)
 type proofview = Proofview_monad.proofview
@@ -44,7 +46,7 @@ let compact el ({ solution } as pv) =
        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));
+  Feedback.msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size));
   new_el, { pv with solution = new_solution; }
 
 
@@ -54,17 +56,21 @@ type telescope =
   | TNil of Evd.evar_map
   | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope)
 
+let typeclass_resolvable = Evd.Store.field ()
+
 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
+  let store = Evd.Store.set Evd.Store.empty typeclass_resolvable () in
   (* Goals don't have a source location. *)
   let src = (Loc.ghost,Evar_kinds.GoalEvar) in
   (* Main routine *)
   let rec aux = function
   | TNil sigma -> [], { solution = sigma; comb = []; shelf = [] }
   | TCons (env, sigma, typ, t) ->
-    let (sigma, econstr ) = Evarutil.new_evar env sigma ~src ~store typ in
+    let sigma = Sigma.Unsafe.of_evar_map sigma in
+    let Sigma (econstr, sigma, _) = Evarutil.new_evar env sigma ~src ~store typ in
+    let sigma = Sigma.to_evar_map sigma in
     let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in
     let (gl, _) = Term.destEvar econstr in
     let entry = (econstr, typ) :: ret in
@@ -146,33 +152,9 @@ let focus i j sp =
   let (new_comb, context) = focus_sublist i j sp.comb in
   ( { sp with comb = new_comb } , context )
 
-
-(** [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
+let undefined defs l = CList.map_filter (Evarutil.advance defs) l
 
 (** Unfocuses a proofview with respect to a context. *)
 let unfocus c sp =
@@ -303,9 +285,9 @@ let tclIFCATCH a s f =
 let tclONCE = Proof.once
 
 exception MoreThanOneSuccess
-let _ = Errors.register_handler begin function
-  | MoreThanOneSuccess -> Errors.error "This tactic has more than one success."
-  | _ -> raise Errors.Unhandled
+let _ = CErrors.register_handler begin function
+  | MoreThanOneSuccess -> CErrors.error "This tactic has more than one success."
+  | _ -> raise CErrors.Unhandled
 end
 
 (** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one
@@ -350,19 +332,19 @@ 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 nosuchgoals_hook:(int -> std_ppcmds) ref = ref (fun n -> mt ())
 let set_nosuchgoals_hook f = nosuchgoals_hook := f
 
 
 
 (* This uses the hook above *)
-let _ = Errors.register_handler begin function
+let _ = CErrors.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
+    let suffix = !nosuchgoals_hook n in
+    CErrors.errorlabstrm ""
+      (str "No such " ++ str (String.plural n "goal") ++ str "." ++
+       pr_non_empty_arg (fun x -> x) suffix)
+      | _ -> raise CErrors.Unhandled
 end
 
 (** [tclFOCUS_gen nosuchgoal i j t] applies [t] in a context where
@@ -383,6 +365,36 @@ let tclFOCUS_gen nosuchgoal i j t =
 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
 
+let tclFOCUSLIST l t =
+  let open Proof in
+  Comb.get >>= fun comb ->
+    let n = CList.length comb in
+    (* First, remove empty intervals, and bound the intervals to the number
+       of goals. *)
+    let sanitize (i, j) =
+      if i > j then None
+      else if i > n then None
+      else if j < 1 then None
+      else Some ((max i 1), (min j n))
+    in
+    let l = CList.map_filter sanitize l in
+    match l with
+      | [] -> tclZERO (NoSuchGoals 0)
+      | (mi, _) :: _ ->
+          (* Get the left-most goal to focus. This goal won't move, and we
+             will then place all the other goals to focus to the right. *)
+          let mi = CList.fold_left (fun m (i, _) -> min m i) mi l in
+          (* [CList.goto] returns a zipper, so that
+             [(rev left) @ sub_right = comb]. *)
+          let left, sub_right = CList.goto (mi-1) comb in
+          let p x _ = CList.exists (fun (i, j) -> i <= x + mi && x + mi <= j) l in
+          let sub, right = CList.partitioni p sub_right in
+          let mj = mi - 1 + CList.length sub in
+            Comb.set (CList.rev_append left (sub @ right)) >>
+            tclFOCUS mi mj t
+
+
+
 (** Like {!tclFOCUS} but selects a single goal by name. *)
 let tclFOCUSID id t =
   let open Proof in
@@ -408,15 +420,15 @@ let tclFOCUSID id t =
 (** {7 Dispatching on goals} *)
 
 exception SizeMismatch of int*int
-let _ = Errors.register_handler begin function
+let _ = CErrors.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
+      CErrors.errorlabstrm "" errmsg
+  | _ -> raise CErrors.Unhandled
 end
 
 (** A variant of [Monad.List.iter] where we iter over the focused list
@@ -429,7 +441,7 @@ let iter_goal i =
   Comb.get >>= fun initial ->
   Proof.List.fold_left begin fun (subgoals as cur) goal ->
     Solution.get >>= fun step ->
-    match advance step goal with
+    match Evarutil.advance step goal with
     | None -> return cur
     | Some goal ->
         Comb.set [goal] >>
@@ -453,7 +465,7 @@ let fold_left2_goal i s l =
   in 
   Proof.List.fold_left2 err begin fun ((r,subgoals) as cur) goal a ->
     Solution.get >>= fun step ->
-    match advance step goal with
+    match Evarutil.advance step goal with
     | None -> return cur
     | Some goal ->
         Comb.set [goal] >>
@@ -497,7 +509,7 @@ let tclDISPATCHGEN0 join tacs =
         let open Proof in
         Pv.get >>= function
         | { comb=[goal] ; solution } ->
-            begin match advance solution goal with
+            begin match Evarutil.advance solution goal with
             | None -> tclUNIT (join [])
             | Some _ -> Proof.map (fun res -> join [res]) tac
             end
@@ -583,6 +595,13 @@ let shelve =
   InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve")) >>
   Shelf.modify (fun gls -> gls @ initial)
 
+let shelve_goals l =
+  let open Proof in
+  Comb.get >>= fun initial ->
+  let comb = CList.filter (fun g -> not (CList.mem g l)) initial in
+  Comb.set comb >>
+  InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_goals")) >>
+  Shelf.modify (fun gls -> gls @ l)
 
 (** [contained_in_info e evi] checks whether the evar [e] appears in
     the hypotheses, the conclusion or the body of the evar_info
@@ -622,18 +641,18 @@ let shelve_unifiable =
   InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >>
   Shelf.modify (fun gls -> gls @ u)
 
-(** [guard_no_unifiable] fails with error [UnresolvedBindings] if some
+(** [guard_no_unifiable] returns the list of unifiable goals 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 ()
+  | [] -> tclUNIT None
   | 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))
+      tclUNIT (Some l)
 
 (** [unshelve l p] adds all the goals in [l] at the end of the focused
     goals of p *)
@@ -642,6 +661,21 @@ let unshelve l p =
   let l = undefined p.solution l in
   { p with comb = p.comb@l }
 
+let mark_in_evm ~goal evd content =
+  let info = Evd.find evd content in
+  let info =
+    if goal then
+      { 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 }
+    else info
+  in
+  let info = match Evd.Store.get info.Evd.evar_extra typeclass_resolvable with
+  | None -> { info with Evd.evar_extra = Evd.Store.set info.Evd.evar_extra typeclass_resolvable () }
+  | Some () -> info
+  in
+  Evd.add evd content info
+
 let with_shelf tac =
   let open Proof in
   Pv.get >>= fun pv ->
@@ -654,17 +688,21 @@ let with_shelf tac =
   let fgoals = Evd.future_goals solution in
   let pgoal = Evd.principal_future_goal solution in
   let sigma = Evd.restore_future_goals sigma fgoals pgoal in
-  Pv.set { npv with shelf; solution = sigma } >>
-  tclUNIT (CList.rev_append gls' gls, ans)
+  (* Ensure we mark and return only unsolved goals *)
+  let gls' = undefined sigma (CList.rev_append gls' gls) in
+  let sigma = CList.fold_left (mark_in_evm ~goal:false) sigma gls' in
+  let npv = { npv with shelf; solution = sigma } in
+  Pv.set npv >> tclUNIT (gls', ans)
 
 (** [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'
+  if m = 0 then 0 else
+    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
@@ -748,9 +786,15 @@ module Progress = struct
   let eq_named_context_val sigma1 sigma2 ctx1 ctx2 =
     let open Environ in
     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) =
-      Names.Id.equal i1 i2 && Option.equal (eq_constr sigma1 sigma2) c1 c2 
-      && (eq_constr sigma1 sigma2) t1 t2
+    let eq_named_declaration d1 d2 =
+      match d1, d2 with
+      | LocalAssum (i1,t1), LocalAssum (i2,t2) ->
+         Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 t1 t2
+      | LocalDef (i1,c1,t1), LocalDef (i2,c2,t2) ->
+         Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 c1 c2
+         && eq_constr sigma1 sigma2 t1 t2
+      | _ ->
+         false
     in List.equal eq_named_declaration c1 c2
 
   let eq_evar_body sigma1 sigma2 b1 b2 =
@@ -795,12 +839,12 @@ let tclPROGRESS t =
   if not test then
     tclUNIT res
   else
-    tclZERO (Errors.UserError ("Proofview.tclPROGRESS" , Pp.str"Failed to progress."))
+    tclZERO (CErrors.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
+let _ = CErrors.register_handler begin function
+  | Timeout -> CErrors.errorlabstrm "Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!")
+  | _ -> Pervasives.raise CErrors.Unhandled
 end
 
 let tclTIMEOUT n t =
@@ -845,7 +889,7 @@ let tclTIME s t =
       else
         str (msg ^ " after ") ++ int n ++ str (String.plural n " backtracking")
     in
-    msg_info(str "Tactic call" ++ pr_opt str s ++ str " ran for " ++
+    Feedback.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
@@ -879,6 +923,8 @@ module Unsafe = struct
       { step with comb = step.comb @ gls }
     end
 
+  let tclSETENV = Env.set
+
   let tclGETGOALS = Comb.get
 
   let tclSETGOALS = Comb.set
@@ -892,61 +938,63 @@ module Unsafe = struct
   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 evd content =
+    mark_in_evm ~goal:true evd content
 
-  let mark_as_goal p gl =
-    { p with solution = mark_as_goal_evm p.solution gl }
+  let advance = Evarutil.advance
 
-end
+  let mark_as_unresolvable p gl =
+    { p with solution = mark_in_evm ~goal:false p.solution gl }
 
+  let typeclass_resolvable = typeclass_resolvable
 
+end
 
-(** {7 Notations} *)
+module UnsafeRepr = Proof.Unsafe
 
-module Notations = struct
-  let (>>=) = tclBIND
-  let (<*>) = tclTHEN
-  let (<+>) t1 t2 = tclOR t1 (fun _ -> t2)
-end
+let (>>=) = tclBIND
 
-open Notations
+(** {6 Goal-dependent tactics} *)
 
+let goal_env evars gl =
+  let evi = Evd.find evars gl in
+  Evd.evar_filtered_env evi
 
+let goal_nf_evar sigma gl =
+  let evi = Evd.find sigma gl in
+  let evi = Evarutil.nf_evar_info sigma evi in
+  let sigma = Evd.add sigma gl evi in
+  (gl, sigma)
 
-(** {6 Goal-dependent tactics} *)
+let goal_extra evars gl =
+  let evi = Evd.find evars gl in
+  evi.Evd.evar_extra
 
-(* To avoid shadowing by the local [Goal] module *)
-module GoalV82 = Goal.V82
 
 let catchable_exception = function
   | Logic_monad.Exception _ -> false
-  | e -> Errors.noncritical e
+  | e -> CErrors.noncritical e
 
 
 module Goal = struct
 
-  type 'a t = {
+  type ('a, 'r) 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)
+  type ('a, 'b) enter =
+    { enter : 'r. ('a, 'r) t -> 'b }
+
+  let assume (gl : ('a, 'r) t) = (gl :> ([ `NF ], 'r) t)
 
   let env { env=env } = env
-  let sigma { sigma=sigma } = sigma
+  let sigma { sigma=sigma } = Sigma.Unsafe.of_evar_map 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 extra { sigma=sigma; self=self } = goal_extra sigma self
 
   let raw_concl { concl=concl } = concl
 
@@ -969,9 +1017,9 @@ module Goal = struct
       tclEVARMAP >>= fun sigma ->
       try
         let (gl, sigma) = nf_gmake env sigma goal in
-        tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f gl))
+        tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f.enter gl))
       with e when catchable_exception e ->
-        let (e, info) = Errors.push e in
+        let (e, info) = CErrors.push e in
         tclZERO ~info e
     end
     end
@@ -987,27 +1035,82 @@ module Goal = struct
     gmake_with info env sigma goal
 
   let enter f =
-    let f gl = InfoL.tag (Info.DBranch) (f gl) in
+    let f gl = InfoL.tag (Info.DBranch) (f.enter 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
+        let (e, info) = CErrors.push e in
+        tclZERO ~info e
+    end
+    end
+
+  exception NotExactlyOneSubgoal
+  let _ = CErrors.register_handler begin function
+  | NotExactlyOneSubgoal ->
+      CErrors.errorlabstrm "" (Pp.str"Not exactly one subgoal.")
+  | _ -> raise CErrors.Unhandled
+  end
+
+  let enter_one f =
+    let open Proof in
+    Comb.get >>= function
+    | [goal] -> begin
+       Env.get >>= fun env ->
+       tclEVARMAP >>= fun sigma ->
+       try f.enter (gmake env sigma goal)
+       with e when catchable_exception e ->
+         let (e, info) = CErrors.push e in
+         tclZERO ~info e
+      end
+    | _ -> tclZERO NotExactlyOneSubgoal
+
+  type ('a, 'b) s_enter =
+    { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma }
+
+  let s_enter f =
+    InfoL.tag (Info.Dispatch) begin
+    iter_goal begin fun goal ->
+      Env.get >>= fun env ->
+      tclEVARMAP >>= fun sigma ->
+      try
+        let gl = gmake env sigma goal in
+        let Sigma (tac, sigma, _) = f.s_enter gl in
+        let sigma = Sigma.to_evar_map sigma in
+        tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac)
+      with e when catchable_exception e ->
+        let (e, info) = CErrors.push e in
+        tclZERO ~info e
+    end
+    end
+
+  let nf_s_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
+        let Sigma (tac, sigma, _) = f.s_enter gl in
+        let sigma = Sigma.to_evar_map sigma in
+        tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac)
+      with e when catchable_exception e ->
+        let (e, info) = CErrors.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
+      match Evarutil.advance sigma goal with
       | None -> None (** ppedrot: Is this check really necessary? *)
       | Some goal ->
         let gl =
+          Env.get >>= fun env ->
           tclEVARMAP >>= fun sigma ->
           tclUNIT (gmake env sigma goal)
         in
@@ -1015,112 +1118,15 @@ module Goal = struct
     in
     tclUNIT (CList.map_filter map step.comb)
 
+  let unsolved { self=self } =
+    tclEVARMAP >>= fun sigma ->
+    tclUNIT (not (Option.is_empty (Evarutil.advance sigma self)))
+
   (* compatibility *)
   let goal { self=self } = self
 
-end
-
-
-
-(** {6 The refine tactic} *)
-
-module Refine =
-struct
-
-  let extract_prefix env info =
-    let ctx1 = List.rev (Environ.named_context env) in
-    let ctx2 = List.rev (Evd.evar_context info) in
-    let rec share l1 l2 accu = match l1, l2 with
-    | d1 :: l1, d2 :: l2 ->
-      if d1 == d2 then share l1 l2 (d1 :: accu)
-      else (accu, d2 :: l2)
-    | _ -> (accu, l2)
-    in
-    share ctx1 ctx2 []
-
-  let typecheck_evar ev env sigma =
-    let info = Evd.find sigma ev in
-    (** Typecheck the hypotheses. *)
-    let type_hyp (sigma, env) (na, body, t as decl) =
-      let evdref = ref sigma in
-      let _ = Typing.sort_of env evdref t in
-      let () = match body with
-      | None -> ()
-      | Some body -> Typing.check env evdref body t
-      in
-      (!evdref, Environ.push_named decl env)
-    in
-    let (common, changed) = extract_prefix env info in
-    let env = Environ.reset_with_named_context (Environ.val_of_named_context common) env in
-    let (sigma, env) = List.fold_left type_hyp (sigma, env) changed in
-    (** Typecheck the conclusion *)
-    let evdref = ref sigma 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
-    (** 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.(hov 2 (str"refine"++spc()++ Hook.get pr_constrv env sigma c)))) >>
-    Pv.modify (fun ps -> { ps with 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 lift (gl : ('a, 'r) t) _ = (gl :> ('a, 's) t)
 
-  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
 
 
@@ -1151,10 +1157,6 @@ 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
@@ -1175,7 +1177,7 @@ module V82 = struct
       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
+        Evd.Monad.List.map (fun g s -> goal_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
@@ -1183,7 +1185,7 @@ module V82 = struct
       InfoL.leaf (Info.Tactic (fun () -> Pp.str"<unknown>")) >>
       Pv.set { ps with solution = evd; comb = sgs; }
     with e when catchable_exception e ->
-      let (e, info) = Errors.push e in
+      let (e, info) = CErrors.push e in
       tclZERO ~info e
 
 
@@ -1191,7 +1193,7 @@ module V82 = struct
      solution. *)
   let nf_evar_goals =
     Pv.modify begin fun ps ->
-    let map g s = GoalV82.nf_evar s g in
+    let map g s = goal_nf_evar s g in
     let (goals,evd) = Evd.Monad.List.map map ps.comb ps.solution in
     { ps with solution = evd; comb = goals; }
     end
@@ -1222,27 +1224,13 @@ module V82 = struct
     in
     CList.flatten (CList.map evars_of_initial initial)
 
-  let instantiate_evar n com pv =
-    let (evk,_) =
-      let evl = Evarutil.non_instantiated pv.solution in
-      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
-	CList.nth evl (n-1)
-    in
-    { pv with
-	solution = Evar_refiner.instantiate_pf_com evk com pv.solution }
-
   let of_tactic t gls =
     try
       let init = { shelf = []; solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in
-      let (_,final,_,_) = apply (GoalV82.env gls.Evd.sigma gls.Evd.it) t init in
+      let (_,final,_,_) = apply (goal_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
+      let (_, info) = CErrors.push src in
       iraise (e, info)
 
   let put_status = Status.put
@@ -1252,6 +1240,18 @@ module V82 = struct
   let wrap_exceptions f =
     try f ()
     with e when catchable_exception e ->
-      let (e, info) = Errors.push e in tclZERO ~info e
+      let (e, info) = CErrors.push e in tclZERO ~info e
 
 end
+
+(** {7 Notations} *)
+
+module Notations = struct
+  let (>>=) = tclBIND
+  let (<*>) = tclTHEN
+  let (<+>) t1 t2 = tclOR t1 (fun _ -> t2)
+  type ('a, 'b) enter = ('a, 'b) Goal.enter =
+    { enter : 'r. ('a, 'r) Goal.t -> 'b }
+  type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter =
+    { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma }
+end
diff --git a/proofs/proofview.mli b/engine/proofview.mli
index 2157459f..90be2f90 100644
--- a/proofs/proofview.mli
+++ b/engine/proofview.mli
@@ -63,7 +63,7 @@ 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. *)
+    unsolved subgoals, but they would then be out of focus. *)
 val finished : proofview -> bool
 
 (** Returns the current [evar] state. *)
@@ -235,10 +235,20 @@ val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic
     This hook is used to add a suggestion about bullets when
     applicable. *)
 exception NoSuchGoals of int
-val set_nosuchgoals_hook: (int -> string option) -> unit
+val set_nosuchgoals_hook: (int -> Pp.std_ppcmds) -> unit
 
 val tclFOCUS : int -> int -> 'a tactic -> 'a tactic
 
+(** [tclFOCUSLIST li t] applies [t] on the list of focused goals
+    described by [li]. Each element of [li] is a pair [(i, j)] denoting
+    the goals numbered from [i] to [j] (inclusive, starting from 1).
+    It will try to apply [t] to all the valid goals in any of these
+    intervals. If the set of such goals is not a single range, then it
+    will move goals such that it is a single range. (So, for
+    instance, [[1, 3-5]; idtac.] is not the identity.)
+    If the set of such goals is empty, it will fail. *)
+val tclFOCUSLIST : (int * int) list -> 'a tactic -> 'a tactic
+
 (** [tclFOCUSID x t] applies [t] on a (single) focused goal like
     {!tclFOCUS}. The goal is found by its name rather than its
     number.*)
@@ -290,21 +300,35 @@ val tclINDEPENDENT : unit tactic -> unit tactic
     shelf for later use (or being solved by side-effects). *)
 val shelve : unit tactic
 
+(** Shelves the given list of goals, which might include some that are
+    under focus and some that aren't. All the goals are placed on the
+    shelf for later use (or being solved by side-effects). *)
+val shelve_goals : Goal.goal list -> unit tactic
+
+(** [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. Used by [shelve_unifiable]. *)
+val unifiable : Evd.evar_map -> Goal.goal -> Goal.goal list -> bool
+
 (** 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
+(** [guard_no_unifiable] returns the list of unifiable goals if some
     goals are unifiable (see {!shelve_unifiable}) in the current focus. *)
-val guard_no_unifiable : unit tactic
+val guard_no_unifiable : Names.Name.t list option 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
 
-(** [with_shelf tac] executes [tac] and returns its result together with the set
-    of goals shelved by [tac]. The current shelf is unchanged. *)
+(** [depends_on g1 g2 sigma] checks if g1 occurs in the type/ctx of g2 *)
+val depends_on : Evd.evar_map -> Goal.goal -> Goal.goal -> bool
+
+(** [with_shelf tac] executes [tac] and returns its result together with
+    the set of goals shelved by [tac]. The current shelf is unchanged
+    and the returned list contains only unsolved goals. *)
 val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic
 
 (** If [n] is positive, [cycle n] puts the [n] first goal last. If [n]
@@ -349,7 +373,6 @@ val mark_as_unsafe : unit tactic
     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
@@ -386,6 +409,9 @@ module Unsafe : sig
   (** Like {!tclEVARS} but also checks whether goals have been solved. *)
   val tclEVARSADVANCE : Evd.evar_map -> unit tactic
 
+  (** Set the global environment of the tactic *)
+  val tclSETENV : Environ.env -> 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. *)
@@ -406,101 +432,107 @@ module Unsafe : sig
 
   (** 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
+  val mark_as_goal : Evd.evar_map -> Evar.t -> Evd.evar_map
 
-(** {7 Notations} *)
+  (** Make an evar unresolvable for type classes. *)
+  val mark_as_unresolvable : proofview -> Evar.t -> proofview
 
-module Notations : sig
+  (** [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. *)
+  val advance : Evd.evar_map -> Evar.t -> Evar.t option
 
-  (** {!tclBIND} *)
-  val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic
-  (** {!tclTHEN} *)
-  val (<*>) : unit tactic -> 'a tactic -> 'a tactic
-  (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *)
-  val (<+>) : 'a tactic -> 'a tactic -> 'a tactic
+  val typeclass_resolvable : unit Evd.Store.field
 
 end
 
+(** This module gives access to the innards of the monad. Its use is
+    restricted to very specific cases. *)
+module UnsafeRepr :
+sig
+  type state = Proofview_monad.Logical.Unsafe.state
+  val repr : 'a tactic -> ('a, state, state, iexn) Logic_monad.BackState.t
+  val make : ('a, state, state, iexn) Logic_monad.BackState.t -> '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
+  (** Type of goals.
+
+      The first 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.
+
+      The second parameter is a stage indicating where the goal belongs. See
+      module {!Sigma}.
+  *)
+  type ('a, 'r) t
 
   (** Assume that you do not need the goal to be normalized. *)
-  val assume : 'a t -> [ `NF ] t
+  val assume : ('a, 'r) t -> ([ `NF ], 'r) t
 
   (** Normalises the argument goal. *)
-  val normalize : 'a t -> [ `NF ] t tactic
+  val normalize : ('a, 'r) t -> ([ `NF ], 'r) 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
+  val concl : ([ `NF ], 'r) t -> Term.constr
+  val hyps : ([ `NF ], 'r) t -> Context.Named.t
+  val env : ('a, 'r) t -> Environ.env
+  val sigma : ('a, 'r) t -> 'r Sigma.t
+  val extra : ('a, 'r) t -> Evd.Store.t
 
   (** Returns the goal's conclusion even if the goal is not
       normalised. *)
-  val raw_concl : 'a t -> Term.constr
+  val raw_concl : ('a, 'r) t -> Term.constr
+
+  type ('a, 'b) enter =
+    { enter : 'r. ('a, 'r) t -> 'b }
 
   (** [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
+  val nf_enter : ([ `NF ], unit tactic) enter -> unit tactic
 
   (** Like {!nf_enter}, but does not normalize the goal beforehand. *)
-  val enter : ([ `LZ ] t -> unit tactic) -> unit tactic
+  val enter : ([ `LZ ], unit tactic) enter -> unit tactic
 
-  (** Recover the list of current goals under focus, without evar-normalization *)
-  val goals : [ `LZ ] t tactic list tactic
+  (** Like {!enter}, but assumes exactly one goal under focus, raising *)
+  (** an error otherwise. *)
+  val enter_one : ([ `LZ ], 'a tactic) enter -> 'a tactic
 
-  (** Compatibility: avoid if possible *)
-  val goal : [ `NF ] t -> Evar.t
+  type ('a, 'b) s_enter =
+    { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma }
 
-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
+  (** A variant of {!enter} allows to work with a monotonic state. The evarmap
+      returned by the argument is put back into the current state before firing
+      the returned tactic. *)
+  val s_enter : ([ `LZ ], unit tactic) s_enter -> unit tactic
 
-  (** {7 Refinement primitives} *)
+  (** Like {!s_enter}, but normalizes the goal beforehand. *)
+  val nf_s_enter : ([ `NF ], unit tactic) s_enter -> unit tactic
 
-  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. *)
+  (** Recover the list of current goals under focus, without evar-normalization.
+      FIXME: encapsulate the level in an existential type. *)
+  val goals : ([ `LZ ], 'r) t tactic list tactic
 
-  (** {7 Helper functions} *)
+  (** [unsolved g] is [true] if [g] is still unsolved in the current
+      proof state. *)
+  val unsolved : ('a, 'r) t -> bool tactic
 
-  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. *)
+  (** Compatibility: avoid if possible *)
+  val goal : ([ `NF ], 'r) t -> Evar.t
 
-  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. *)
+  (** Every goal is valid at a later stage. FIXME: take a later evarmap *)
+  val lift : ('a, 'r) t -> ('r, 's) Sigma.le -> ('a, 's) t
 
 end
 
@@ -558,9 +590,6 @@ module V82 : sig
   
   (* returns the existential variable used to start the proof *)
   val top_evars : entry -> Evd.evar list
-    
-  (* Implements the Existential command *)
-  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
@@ -578,3 +607,20 @@ module V82 : sig
      the monad. *)
   val wrap_exceptions : (unit -> 'a tactic) -> 'a tactic
 end
+
+(** {7 Notations} *)
+
+module Notations : sig
+
+  (** {!tclBIND} *)
+  val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic
+  (** {!tclTHEN} *)
+  val (<*>) : unit tactic -> 'a tactic -> 'a tactic
+  (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *)
+  val (<+>) : 'a tactic -> 'a tactic -> 'a tactic
+
+  type ('a, 'b) enter = ('a, 'b) Goal.enter =
+    { enter : 'r. ('a, 'r) Goal.t -> 'b }
+  type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter =
+    { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma }
+end
diff --git a/proofs/proofview_monad.ml b/engine/proofview_monad.ml
index e9bc7761..6f52b3ee 100644
--- a/proofs/proofview_monad.ml
+++ b/engine/proofview_monad.ml
@@ -108,11 +108,6 @@ module Info = struct
   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
@@ -159,8 +154,8 @@ end
     focused goals. *)
 type proofview = {
   solution : Evd.evar_map;
-  comb : Goal.goal list;
-  shelf : Goal.goal list;
+  comb : Evar.t list;
+  shelf : Evar.t list;
 }
 
 (** {6 Instantiation of the logic monad} *)
diff --git a/proofs/proofview_monad.mli b/engine/proofview_monad.mli
index 7a6ea10f..637414cc 100644
--- a/proofs/proofview_monad.mli
+++ b/engine/proofview_monad.mli
@@ -7,7 +7,8 @@
 (************************************************************************)
 
 (** This file defines the datatypes used as internal states by the
-    tactic monad, and specialises the [Logic_monad] to these type. *)
+    tactic monad, and specialises the [Logic_monad] to these types. It should
+    not be used directly. Consider using {!Proofview} instead. *)
 
 (** {6 Traces} *)
 
@@ -70,8 +71,8 @@ end
     focused goals. *)
 type proofview = {
   solution : Evd.evar_map;
-  comb : Goal.goal list;
-  shelf : Goal.goal list;
+  comb : Evar.t list;
+  shelf : Evar.t list;
 }
 
 (** {6 Instantiation of the logic monad} *)
diff --git a/engine/sigma.ml b/engine/sigma.ml
new file mode 100644
index 00000000..9381a33a
--- /dev/null
+++ b/engine/sigma.ml
@@ -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        *)
+(************************************************************************)
+
+type 'a t = Evd.evar_map
+
+type ('a, 'b) le = unit
+
+let refl = ()
+let cons _ _  = ()
+let (+>) = fun _ _ -> ()
+
+type ('a, 'r) sigma = Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma
+
+type 'a evar = Evar.t
+
+let lift_evar evk () = evk
+
+let to_evar_map evd = evd
+let to_evar evk = evk
+
+let here x s = Sigma (x, s, ())
+
+(** API *)
+
+type 'r fresh = Fresh : 's evar * 's t * ('r, 's) le -> 'r fresh
+
+let new_evar sigma ?naming info =
+  let (sigma, evk) = Evd.new_evar sigma ?naming info in
+  Fresh (evk, sigma, ())
+
+let define evk c sigma =
+  Sigma ((), Evd.define evk c sigma, ())
+
+let new_univ_level_variable ?loc ?name rigid sigma =
+  let (sigma, u) = Evd.new_univ_level_variable ?loc ?name rigid sigma in
+  Sigma (u, sigma, ())
+
+let new_univ_variable ?loc ?name rigid sigma =
+  let (sigma, u) = Evd.new_univ_variable ?loc ?name rigid sigma in
+  Sigma (u, sigma, ())
+
+let new_sort_variable ?loc ?name rigid sigma =
+  let (sigma, u) = Evd.new_sort_variable ?loc ?name rigid sigma in
+  Sigma (u, sigma, ())
+
+let fresh_sort_in_family ?loc ?rigid env sigma s =
+  let (sigma, s) = Evd.fresh_sort_in_family ?loc ?rigid env sigma s in
+  Sigma (s, sigma, ())
+
+let fresh_constant_instance ?loc env sigma cst =
+  let (sigma, cst) = Evd.fresh_constant_instance ?loc env sigma cst in
+  Sigma (cst, sigma, ())
+
+let fresh_inductive_instance ?loc env sigma ind =
+  let (sigma, ind) = Evd.fresh_inductive_instance ?loc env sigma ind in
+  Sigma (ind, sigma, ())
+
+let fresh_constructor_instance ?loc env sigma pc =
+  let (sigma, c) = Evd.fresh_constructor_instance ?loc env sigma pc in
+  Sigma (c, sigma, ())
+
+let fresh_global ?loc ?rigid ?names env sigma r =
+  let (sigma, c) = Evd.fresh_global ?loc ?rigid ?names env sigma r in
+  Sigma (c, sigma, ())
+
+(** Run *)
+
+type 'a run = { run : 'r. 'r t -> ('a, 'r) sigma }
+
+let run sigma f : 'a * Evd.evar_map =
+  let Sigma (x, sigma, ()) = f.run sigma in
+  (x, sigma)
+
+(** Monotonic references *)
+
+type evdref = Evd.evar_map ref
+
+let apply evdref f =
+  let Sigma (x, sigma, ()) = f.run !evdref in
+  evdref := sigma;
+  x
+
+let purify f =
+  let f (sigma : Evd.evar_map) =
+    let evdref = ref sigma in
+    let ans = f evdref in
+    Sigma (ans, !evdref, ())
+  in
+  { run = f }
+
+(** Unsafe primitives *)
+
+module Unsafe =
+struct
+
+let le = ()
+let of_evar_map sigma = sigma
+let of_evar evk = evk
+let of_ref ref = ref
+let of_pair (x, sigma) = Sigma (x, sigma, ())
+
+end
+
+module Notations =
+struct
+  type ('a, 'r) sigma_ = ('a, 'r) sigma =
+    Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma_
+
+  let (+>) = fun _ _ -> ()
+
+  type 'a run_ = 'a run = { run : 'r. 'r t -> ('a, 'r) sigma }
+end
diff --git a/engine/sigma.mli b/engine/sigma.mli
new file mode 100644
index 00000000..7473a251
--- /dev/null
+++ b/engine/sigma.mli
@@ -0,0 +1,131 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - 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
+
+(** Monotonous state enforced by typing.
+
+    This module allows to constrain uses of evarmaps in a monotonous fashion,
+    and in particular statically suppress evar leaks and the like. To this
+    ends, it defines a type of indexed evarmaps whose phantom typing ensures
+    monotonous use.
+*)
+
+(** {5 Stages} *)
+
+type ('a, 'b) le
+(** Relationship stating that stage ['a] is anterior to stage ['b] *)
+
+val refl : ('a, 'a) le
+(** Reflexivity of anteriority *)
+
+val cons : ('a, 'b) le -> ('b, 'c) le -> ('a, 'c) le
+(** Transitivity of anteriority *)
+
+val (+>) : ('a, 'b) le -> ('b, 'c) le -> ('a, 'c) le
+(** Alias for {!cons} *)
+
+(** {5 Monotonous evarmaps} *)
+
+type 'r t
+(** Stage-indexed evarmaps. This is just a plain evarmap with a phantom type. *)
+
+type ('a, 'r) sigma = Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma
+(** Return values at a later stage *)
+
+type 'r evar
+(** Stage-indexed evars *)
+
+(** {5 Constructors} *)
+
+val here : 'a -> 'r t -> ('a, 'r) sigma
+(** [here x s] is a shorthand for [Sigma (x, s, refl)] *)
+
+(** {5 Postponing} *)
+
+val lift_evar : 'r evar -> ('r, 's) le -> 's evar
+(** Any evar existing at stage ['r] is also valid at any later stage. *)
+
+(** {5 Downcasting} *)
+
+val to_evar_map : 'r t -> Evd.evar_map
+val to_evar : 'r evar -> Evar.t
+
+(** {5 Monotonous API} *)
+
+type 'r fresh = Fresh : 's evar * 's t * ('r, 's) le -> 'r fresh
+
+val new_evar : 'r t -> ?naming:Misctypes.intro_pattern_naming_expr ->
+  Evd.evar_info -> 'r fresh
+
+val define : 'r evar -> Constr.t -> 'r t -> (unit, 'r) sigma
+
+(** Polymorphic universes *)
+
+val new_univ_level_variable : ?loc:Loc.t -> ?name:string ->
+  Evd.rigid -> 'r t -> (Univ.universe_level, 'r) sigma
+val new_univ_variable : ?loc:Loc.t -> ?name:string ->
+  Evd.rigid -> 'r t -> (Univ.universe, 'r) sigma
+val new_sort_variable : ?loc:Loc.t -> ?name:string ->
+  Evd.rigid -> 'r t -> (Sorts.t, 'r) sigma
+
+val fresh_sort_in_family : ?loc:Loc.t -> ?rigid:Evd.rigid -> Environ.env ->
+  'r t -> Term.sorts_family -> (Term.sorts, 'r) sigma
+val fresh_constant_instance :
+  ?loc:Loc.t -> Environ.env -> 'r t -> constant -> (pconstant, 'r) sigma
+val fresh_inductive_instance :
+  ?loc:Loc.t -> Environ.env -> 'r t -> inductive -> (pinductive, 'r) sigma
+val fresh_constructor_instance : ?loc:Loc.t -> Environ.env -> 'r t -> constructor ->
+  (pconstructor, 'r) sigma
+
+val fresh_global : ?loc:Loc.t -> ?rigid:Evd.rigid -> ?names:Univ.Instance.t -> Environ.env ->
+  'r t -> Globnames.global_reference -> (constr, 'r) sigma
+
+(** FILLME *)
+
+(** {5 Run} *)
+
+type 'a run = { run : 'r. 'r t -> ('a, 'r) sigma }
+
+val run : Evd.evar_map -> 'a run -> 'a * Evd.evar_map
+
+(** {5 Imperative monotonic functions} *)
+
+type evdref
+(** Monotonic references over evarmaps *)
+
+val apply : evdref -> 'a run -> 'a
+(** Apply a monotonic function on a reference. *)
+
+val purify : (evdref -> 'a) -> 'a run
+(** Converse of {!apply}. *)
+
+(** {5 Unsafe primitives} *)
+
+module Unsafe :
+sig
+  val le : ('a, 'b) le
+  val of_evar_map : Evd.evar_map -> 'r t
+  val of_evar : Evd.evar -> 'r evar
+  val of_ref : Evd.evar_map ref -> evdref
+  val of_pair : ('a * Evd.evar_map) -> ('a, 'r) sigma
+end
+
+(** {5 Notations} *)
+
+module Notations :
+sig
+  type ('a, 'r) sigma_ = ('a, 'r) sigma =
+    Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma_
+
+  type 'a run_ = 'a run = { run : 'r. 'r t -> ('a, 'r) sigma }
+
+  val (+>) : ('a, 'b) le -> ('b, 'c) le -> ('a, 'c) le
+  (** Alias for {!cons} *)
+end
diff --git a/pretyping/termops.ml b/engine/termops.ml
index 9d469cb7..697b9a5f 100644
--- a/pretyping/termops.ml
+++ b/engine/termops.ml
@@ -7,15 +7,17 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
 open Term
 open Vars
-open Context
 open Environ
 
+module RelDecl = Context.Rel.Declaration
+module NamedDecl = Context.Named.Declaration
+
 (* Sorts and sort family *)
 
 let print_sort = function
@@ -99,26 +101,28 @@ let print_constr_env t = !term_printer t
 let print_constr t = !term_printer (Global.env()) t
 let set_print_constr f = term_printer := f
 
-let pr_var_decl env (id,c,typ) =
-  let pbody = match c with
-    | None ->  (mt ())
-    | Some c ->
+let pr_var_decl env decl =
+  let open NamedDecl in
+  let pbody = match decl with
+    | LocalAssum _ ->  mt ()
+    | LocalDef (_,c,_) ->
 	(* Force evaluation *)
 	let pb = print_constr_env env c in
 	  (str" := " ++ pb ++ cut () ) in
-  let pt = print_constr_env env typ in
+  let pt = print_constr_env env (get_type decl) in
   let ptyp = (str" : " ++ pt) in
-    (pr_id id ++ hov 0 (pbody ++ ptyp))
+    (pr_id (get_id decl) ++ hov 0 (pbody ++ ptyp))
 
-let pr_rel_decl env (na,c,typ) =
-  let pbody = match c with
-    | None -> mt ()
-    | Some c ->
+let pr_rel_decl env decl =
+  let open RelDecl in
+  let pbody = match decl with
+    | LocalAssum _ -> mt ()
+    | LocalDef (_,c,_) ->
 	(* Force evaluation *)
 	let pb = print_constr_env env c in
 	  (str":=" ++ spc () ++ pb ++ spc ()) in
-  let ptyp = print_constr_env env typ in
-    match na with
+  let ptyp = print_constr_env env (get_type decl) in
+    match get_name decl with
       | Anonymous -> hov 0 (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp)
       | Name id -> hov 0 (pr_id id ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp)
 
@@ -158,55 +162,53 @@ let rel_list n m =
   in
   reln [] 1
 
-(* Same as [rel_list] but takes a context as argument and skips let-ins *)
-let extended_rel_list n hyps =
-  let rec reln l p = function
-    | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps
-    | (_,Some _,_) :: hyps -> reln l (p+1) hyps
-    | [] -> l
-  in
-  reln [] 1 hyps
-
-let extended_rel_vect n hyps = Array.of_list (extended_rel_list n hyps)
-
-
-
-let push_rel_assum (x,t) env = push_rel (x,None,t) env
+let push_rel_assum (x,t) env =
+  let open RelDecl in
+  push_rel (LocalAssum (x,t)) env
 
 let push_rels_assum assums =
-  push_rel_context (List.map (fun (x,t) -> (x,None,t)) assums)
+  let open RelDecl in
+  push_rel_context (List.map (fun (x,t) -> LocalAssum (x,t)) assums)
 
 let push_named_rec_types (lna,typarray,_) env =
+  let open NamedDecl in
   let ctxt =
     Array.map2_i
       (fun i na t ->
 	 match na with
-	   | Name id -> (id, None, lift i t)
+	   | Name id -> LocalAssum (id, lift i t)
 	   | 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 lookup_rel_id id sign =
+  let open RelDecl in
   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
+    | [] ->
+        raise Not_found
+    | (LocalAssum (Anonymous, _) | LocalDef (Anonymous,_,_)) :: l ->
+        lookrec (n + 1) l
+    | LocalAssum (Name id', t) :: l  ->
+        if Names.Id.equal id' id then (n,None,t)  else lookrec (n + 1) l
+    | LocalDef (Name id', b, t) :: l  ->
+        if Names.Id.equal id' id then (n,Some b,t) else lookrec (n + 1) l
   in
   lookrec 1 sign
 
 (* Constructs either [forall x:t, c] or [let x:=b:t in c] *)
-let mkProd_or_LetIn (na,body,t) c =
-  match body with
-    | None -> mkProd (na, t, c)
-    | Some b -> mkLetIn (na, b, t, c)
+let mkProd_or_LetIn decl c =
+  let open RelDecl in
+  match decl with
+    | LocalAssum (na,t) -> mkProd (na, t, c)
+    | LocalDef (na,b,t) -> mkLetIn (na, b, t, c)
 
 (* Constructs either [forall x:t, c] or [c] in which [x] is replaced by [b] *)
-let mkProd_wo_LetIn (na,body,t) c =
-  match body with
-    | None -> mkProd (na,  t, c)
-    | Some b -> subst1 b c
+let mkProd_wo_LetIn decl c =
+  let open RelDecl in
+  match decl with
+    | LocalAssum (na,t) -> mkProd (na, t, c)
+    | LocalDef (_,b,_) -> subst1 b c
 
 let it_mkProd init = List.fold_left (fun c (n,t)  -> mkProd (n, t, c)) init
 let it_mkLambda init = List.fold_left (fun c (n,t)  -> mkLambda (n, t, c)) init
@@ -222,10 +224,11 @@ let it_mkNamedProd_wo_LetIn init = it_named_context_quantifier mkNamedProd_wo_Le
 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 open RelDecl in
   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)
+  | LocalDef (na,b,t) :: decls -> mkLetIn (na,b,t,aux (k-1) decls (liftn 1 k c))
+  | LocalAssum (na,t) :: decls -> mkLambda (na,t,aux (k-1) decls c)
   in aux (List.length decls) (List.rev decls) c
 
 (* *)
@@ -316,7 +319,7 @@ 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 -> RelDecl.LocalAssum (na, lift i t)) lna typarray in
   Array.fold_left (fun e assum -> g assum e) e ctxt
 
 let map_left2 f a g b =
@@ -331,7 +334,9 @@ let map_left2 f a g b =
     r, s
   end
 
-let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with
+let map_constr_with_binders_left_to_right g f l c =
+  let open RelDecl in
+  match kind_of_term c with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> c
   | Cast (b,k,t) -> 
@@ -341,18 +346,18 @@ let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with
       else mkCast (b',k,t')
   | Prod (na,t,b) ->
       let t' = f l t in
-      let b' = f (g (na,None,t) l) b in
+      let b' = f (g (LocalAssum (na,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
-      let b' = f (g (na,None,t) l) b in
+      let b' = f (g (LocalAssum (na,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 b' = f (g (na,Some bo,t) l) b in
+      let b' = f (g (LocalDef (na,bo,t)) l) b in
 	if bo' == bo && t' == t && b' == b then c
 	else mkLetIn (na, bo', t', b')	    
   | App (c,[||]) -> assert false
@@ -393,7 +398,9 @@ let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with
 	else mkCoFix (ln,(lna,tl',bl'))
 
 (* strong *)
-let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with
+let map_constr_with_full_binders g f l cstr =
+  let open RelDecl in
+  match kind_of_term cstr with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> cstr
   | Cast (c,k, t) ->
@@ -402,16 +409,16 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with
       if c==c' && t==t' then cstr else mkCast (c', k, t')
   | Prod (na,t,c) ->
       let t' = f l t in
-      let c' = f (g (na,None,t) l) c in
+      let c' = f (g (LocalAssum (na,t)) l) c in
       if t==t' && c==c' then cstr else mkProd (na, t', c')
   | Lambda (na,t,c) ->
       let t' = f l t in
-      let c' = f (g (na,None,t) l) c in
+      let c' = f (g (LocalAssum (na,t)) l) c in
       if t==t' && c==c' then cstr 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 (na,Some b,t) l) c in
+      let c' = f (g (LocalDef (na,b,t)) l) c in
       if b==b' && t==t' && c==c' then cstr else mkLetIn (na, b', t', c')
   | App (c,al) ->
       let c' = f l c in
@@ -432,7 +439,7 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with
   | 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 (LocalAssum (na,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'
       then cstr
@@ -440,7 +447,7 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with
   | 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 (LocalAssum (na,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'
       then cstr
@@ -453,23 +460,25 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with
    index) which is processed by [g] (which typically add 1 to [n]) at
    each binder traversal; it is not recursive *)
 
-let fold_constr_with_full_binders g f n acc c = match kind_of_term c with
+let fold_constr_with_full_binders g f n acc c =
+  let open RelDecl in
+  match kind_of_term c with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> acc
   | Cast (c,_, t) -> f n (f n acc c) t
-  | Prod (na,t,c) -> f (g (na,None,t) n) (f n acc t) c
-  | Lambda (na,t,c) -> f (g (na,None,t) n) (f n acc t) c
-  | LetIn (na,b,t,c) -> f (g (na,Some b,t) n) (f n (f n acc b) t) c
+  | Prod (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c
+  | Lambda (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c
+  | LetIn (na,b,t,c) -> f (g (LocalDef (na,b,t)) 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' = CArray.fold_left2 (fun c n t -> g (n,None,t) c) n lna tl in
+      let n' = CArray.fold_left2 (fun c n t -> g (LocalAssum (n,t)) c) n lna tl 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' = CArray.fold_left2 (fun c n t -> g (n,None,t) c) n lna tl in
+      let n' = CArray.fold_left2 (fun c n t -> g (LocalAssum (n,t)) c) n lna tl 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
 
@@ -481,23 +490,25 @@ let fold_constr_with_binders g f n acc c =
    each binder traversal; it is not recursive and the order with which
    subterms are processed is not specified *)
 
-let iter_constr_with_full_binders g f l c = match kind_of_term c with
+let iter_constr_with_full_binders g f l c =
+  let open RelDecl in
+  match kind_of_term c with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> ()
   | Cast (c,_, t) -> f l c; f l t
-  | Prod (na,t,c) -> f l t; f (g (na,None,t) l) c
-  | 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
+  | Prod (na,t,c) -> f l t; f (g (LocalAssum (na,t)) l) c
+  | Lambda (na,t,c) -> f l t; f (g (LocalAssum (na,t)) l) c
+  | LetIn (na,b,t,c) -> f l b; f l t; f (g (LocalDef (na,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 (LocalAssum (na,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 (LocalAssum (na,t)) l) l lna tl in
       Array.iter (f l) tl;
       Array.iter (f l') bl
 
@@ -545,14 +556,22 @@ let occur_var env id c =
   in
   try occur_rec c; false with Occur -> true
 
-let occur_var_in_decl env hyp (_,c,typ) =
-  match c with
-    | None -> occur_var env hyp typ
-    | Some body ->
+let occur_var_in_decl env hyp decl =
+  let open NamedDecl in
+  match decl with
+    | LocalAssum (_,typ) -> occur_var env hyp typ
+    | LocalDef (_, body, typ) ->
         occur_var env hyp typ ||
         occur_var env hyp body
 
-(* returns the list of free debruijn indices in a term *)
+let local_occur_var id c =
+  let rec occur c = match kind_of_term c with
+  | Var id' -> if Id.equal id id' then raise Occur
+  | _ -> Constr.iter occur c
+  in
+  try occur c; false with Occur -> true
+
+  (* returns the list of free debruijn indices in a term *)
 
 let free_rels m =
   let rec frec depth acc c = match kind_of_term c with
@@ -580,6 +599,10 @@ let collect_vars c =
   | _ -> fold_constr aux vars c in
   aux Id.Set.empty c
 
+let vars_of_global_reference env gr =
+  let c, _ = Universes.unsafe_constr_of_global gr in
+  vars_of_global (Global.env ()) c
+
 (* Tests whether [m] is a subterm of [t]:
    [m] is appropriately lifted through abstractions of [t] *)
 
@@ -607,10 +630,11 @@ 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 dependent_in_decl a decl =
+  let open NamedDecl in
+  match decl with
+    | LocalAssum (_,t) -> dependent a t
+    | LocalDef (_, body, t) -> dependent a body || dependent a t
 
 let count_occurrences m t =
   let n = ref 0 in
@@ -713,10 +737,10 @@ let replace_term = replace_term_gen eq_constr
 
 let vars_of_env env =
   let s =
-    Context.fold_named_context (fun (id,_,_) s -> Id.Set.add id s)
+    Context.Named.fold_outside (fun decl s -> Id.Set.add (NamedDecl.get_id decl) 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)
+  Context.Rel.fold_outside
+    (fun decl s -> match RelDecl.get_name decl with Name id -> Id.Set.add id s | _ -> s)
     (rel_context env) ~init:s
 
 let add_vname vars = function
@@ -741,12 +765,12 @@ let lookup_rel_of_name id names =
 let empty_names_context = []
 
 let ids_of_rel_context sign =
-  Context.fold_rel_context
-    (fun (na,_,_) l -> match na with Name id -> id::l | Anonymous -> l)
+  Context.Rel.fold_outside
+    (fun decl l -> match RelDecl.get_name decl with Name id -> id::l | Anonymous -> l)
     sign ~init:[]
 
 let ids_of_named_context sign =
-  Context.fold_named_context (fun (id,_,_) idl -> id::idl) sign ~init:[]
+  Context.Named.fold_outside (fun decl idl -> NamedDecl.get_id decl :: idl) sign ~init:[]
 
 let ids_of_context env =
   (ids_of_rel_context (rel_context env))
@@ -754,7 +778,7 @@ let ids_of_context env =
 
 
 let names_of_rel_context env =
-  List.map (fun (na,_,_) -> na) (rel_context env)
+  List.map RelDecl.get_name (rel_context env)
 
 let is_section_variable id =
   try let _ = Global.lookup_named id in true
@@ -801,7 +825,7 @@ let split_app c = match kind_of_term c with
 	c::(Array.to_list prev), last
   | _ -> assert false
 
-type subst = (rel_context*constr) Evar.Map.t
+type subst = (Context.Rel.t * constr) Evar.Map.t
 
 exception CannotFilter
 
@@ -827,7 +851,7 @@ let filtering env cv_pb c1 c2 =
         end
       | Prod (n,t1,c1), Prod (_,t2,c2) ->
 	  aux env cv_pb t1 t2;
-	  aux ((n,None,t1)::env) cv_pb c1 c2
+	  aux (RelDecl.LocalAssum (n,t1) :: env) cv_pb c1 c2
       | _, Evar (ev,_) -> define cv_pb env ev c1
       | Evar (ev,_), _ -> define cv_pb env ev c2
       | _ ->
@@ -838,15 +862,43 @@ let filtering env cv_pb c1 c2 =
   in
   aux env cv_pb c1 c2; !evm
 
-let decompose_prod_letin : constr -> int * rel_context * constr =
+let decompose_prod_letin : constr -> int * Context.Rel.t * constr =
   let rec prodec_rec i l c = match kind_of_term c with
-    | Prod (n,t,c)    -> prodec_rec (succ i) ((n,None,t)::l) c
-    | LetIn (n,d,t,c) -> prodec_rec (succ i) ((n,Some d,t)::l) c
+    | Prod (n,t,c)    -> prodec_rec (succ i) (RelDecl.LocalAssum (n,t)::l) c
+    | LetIn (n,d,t,c) -> prodec_rec (succ i) (RelDecl.LocalDef (n,d,t)::l) c
     | Cast (c,_,_)    -> prodec_rec i l c
     | _               -> i,l,c in
   prodec_rec 0 []
 
-let align_prod_letin c a : rel_context * constr =
+(* (nb_lam [na1:T1]...[nan:Tan]c) where c is not an abstraction
+ * gives n (casts are ignored) *)
+let nb_lam =
+  let rec nbrec n c = match kind_of_term c with
+    | Lambda (_,_,c) -> nbrec (n+1) c
+    | Cast (c,_,_) -> nbrec n c
+    | _ -> n
+  in
+  nbrec 0
+
+(* similar to nb_lam, but gives the number of products instead *)
+let nb_prod =
+  let rec nbrec n c = match kind_of_term c with
+    | Prod (_,_,c) -> nbrec (n+1) c
+    | Cast (c,_,_) -> nbrec n c
+    | _ -> n
+  in
+  nbrec 0
+
+let nb_prod_modulo_zeta x =
+  let rec count n c =
+    match kind_of_term c with
+        Prod(_,_,t) -> count (n+1) t
+      | LetIn(_,a,_,t) -> count n (subst1 a t)
+      | Cast(c,_,_) -> count n c
+      | _ -> n
+  in count 0 x
+
+let align_prod_letin c a : Context.Rel.t * 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";
@@ -884,20 +936,20 @@ 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
-  Context.fold_rel_context f rels ~init:env0
+  Context.Rel.fold_outside f rels ~init:env0
 
 let assums_of_rel_context sign =
-  Context.fold_rel_context
-    (fun (na,c,t) l ->
-      match c with
-          Some _ -> l
-        | None -> (na, t)::l)
+  Context.Rel.fold_outside
+    (fun decl l ->
+      match decl with
+      | RelDecl.LocalDef _ -> l
+      | RelDecl.LocalAssum (na,t) -> (na, t)::l)
     sign ~init:[]
 
 let map_rel_context_in_env f env sign =
   let rec aux env acc = function
     | d::sign ->
-	aux (push_rel d env) (map_rel_declaration (f env) d :: acc) sign
+	aux (push_rel d env) (RelDecl.map_constr (f env) d :: acc) sign
     | [] ->
 	acc
   in
@@ -905,10 +957,10 @@ let map_rel_context_in_env f env sign =
 
 let map_rel_context_with_binders f sign =
   let rec aux k = function
-    | d::sign -> map_rel_declaration (f k) d :: aux (k-1) sign
+    | d::sign -> RelDecl.map_constr (f k) d :: aux (k-1) sign
     | [] -> []
   in
-  aux (rel_context_length sign) sign
+  aux (Context.Rel.length sign) sign
 
 let substl_rel_context l =
   map_rel_context_with_binders (fun k -> substnl l (k-1))
@@ -919,60 +971,51 @@ let lift_rel_context n =
 let smash_rel_context sign =
   let rec aux acc = function
   | [] -> acc
-  | (_,None,_ as d) :: l -> aux (d::acc) l
-  | (_,Some b,_) :: l ->
+  | (RelDecl.LocalAssum _ as d) :: l -> aux (d::acc) l
+  | RelDecl.LocalDef (_,b,_) :: l ->
       (* Quadratic in the number of let but there are probably a few of them *)
       aux (List.rev (substl_rel_context [b] (List.rev acc))) l
   in List.rev (aux [] sign)
 
-let adjust_subst_to_rel_context sign l =
-  let rec aux subst sign l =
-    match sign, l with
-    | (_,None,_)::sign', a::args' -> aux (a::subst) sign' args'
-    | (_,Some c,_)::sign', args' ->
-	aux (substl subst c :: subst) sign' args'
-    | [], [] -> List.rev subst
-    | _ -> 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 rec mem_named_context id = function
-  | (id',_,_) :: _ when Id.equal id id' -> true
-  | _ :: sign -> mem_named_context id sign
-  | [] -> false
+let mem_named_context_val id ctxt =
+  try ignore(Environ.lookup_named_val id ctxt); true with Not_found -> false
 
 let compact_named_context_reverse sign =
-  let compact l (i1,c1,t1) =
+  let compact l decl =
+    let (i1,c1,t1) = NamedDecl.to_tuple decl in
     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
+  in Context.Named.fold_inside compact ~init:[] sign
 
 let compact_named_context sign = List.rev (compact_named_context_reverse sign)
 
 let clear_named_body id env =
+  let open NamedDecl in
   let aux _ = function
-  | (id',Some c,t) when Id.equal id id' -> push_named (id,None,t)
+  | LocalDef (id',c,t) when Id.equal id id' -> push_named (LocalAssum (id,t))
   | d -> push_named d in
   fold_named_context aux env ~init:(reset_context env)
 
 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) ->
+  | NamedDecl.LocalAssum (_,t) -> global_vars_set env t
+  | NamedDecl.LocalDef (_,c,t) ->
       Id.Set.union (global_vars_set env t)
         (global_vars_set env c)
 
 let dependency_closure env sign hyps =
   if Id.Set.is_empty hyps then [] else
     let (_,lh) =
-      Context.fold_named_context_reverse
-        (fun (hs,hl) (x,_,_ as d) ->
+      Context.Named.fold_inside
+        (fun (hs,hl) d ->
+          let x = NamedDecl.get_id d in
           if Id.Set.mem x hs then
             (Id.Set.union (global_vars_set_of_decl env d) (Id.Set.remove x hs),
             x::hl)
@@ -987,12 +1030,12 @@ let on_judgment f j = { uj_val = f j.uj_val; uj_type = f j.uj_type }
 let on_judgment_value f j = { j with uj_val = f j.uj_val }
 let on_judgment_type f j = { j with uj_type = f j.uj_type }
 
-(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k
-     variables; skips let-in's *)
+(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k non let-in
+     variables skips let-in's; let-in's in the middle are put in ctx2 *)
 let context_chop k ctx =
   let rec chop_aux acc = function
     | (0, l2) -> (List.rev acc, l2)
-    | (n, ((_,Some _,_ as h)::t)) -> chop_aux (h::acc) (n, t)
+    | (n, (RelDecl.LocalDef _ as h)::t) -> chop_aux (h::acc) (n, t)
     | (n, (h::t)) -> chop_aux (h::acc) (pred n, t)
     | (_, []) -> anomaly (Pp.str "context_chop")
   in chop_aux [] (k,ctx)
diff --git a/pretyping/termops.mli b/engine/termops.mli
index ca98f8d7..fd8edafb 100644
--- a/pretyping/termops.mli
+++ b/engine/termops.mli
@@ -6,10 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(** This file defines various utilities for term manipulation that are not
+    needed in the kernel. *)
+
 open Pp
 open Names
 open Term
-open Context
 open Environ
 
 (** printers *)
@@ -22,7 +24,7 @@ val set_print_constr : (env -> constr -> std_ppcmds) -> unit
 val print_constr     : constr -> std_ppcmds
 val print_constr_env : env -> constr -> std_ppcmds
 val print_named_context : env -> std_ppcmds
-val pr_rel_decl : env -> rel_declaration -> std_ppcmds
+val pr_rel_decl : env -> Context.Rel.Declaration.t -> std_ppcmds
 val print_rel_context : env -> std_ppcmds
 val print_env : env -> std_ppcmds
 
@@ -31,35 +33,31 @@ 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
+val lookup_rel_id : Id.t -> Context.Rel.t -> 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
-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 mkProd_or_LetIn : Context.Rel.Declaration.t -> types -> types
+val mkProd_wo_LetIn : Context.Rel.Declaration.t -> types -> types
 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
-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_mkProd_or_LetIn : types -> Context.Rel.t -> types
+val it_mkProd_wo_LetIn : types -> Context.Rel.t -> types
+val it_mkLambda_or_LetIn : constr -> Context.Rel.t -> constr
+val it_mkNamedProd_or_LetIn : types -> Context.Named.t -> types
+val it_mkNamedProd_wo_LetIn : types -> Context.Named.t -> types
+val it_mkNamedLambda_or_LetIn : constr -> Context.Named.t -> constr
 
 (* 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
+val it_mkLambda_or_LetIn_from_no_LetIn : constr -> Context.Rel.t -> constr
 
 (** {6 Generic iterators on constr} *)
 
@@ -67,11 +65,11 @@ val map_constr_with_named_binders :
   (Name.t -> 'a -> 'a) ->
   ('a -> constr -> constr) -> 'a -> constr -> constr
 val map_constr_with_binders_left_to_right :
-  (rel_declaration -> 'a -> 'a) ->
+  (Context.Rel.Declaration.t -> 'a -> 'a) ->
   ('a -> constr -> constr) ->
     'a -> constr -> constr
 val map_constr_with_full_binders :
-  (rel_declaration -> 'a -> 'a) ->
+  (Context.Rel.Declaration.t -> 'a -> 'a) ->
   ('a -> constr -> constr) -> 'a -> constr -> constr
 
 (** [fold_constr_with_binders g f n acc c] folds [f n] on the immediate
@@ -85,11 +83,11 @@ val fold_constr_with_binders :
   ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b
 
 val fold_constr_with_full_binders :
-  (rel_declaration -> 'a -> 'a) -> ('a -> 'b -> constr -> 'b) ->
+  (Context.Rel.Declaration.t -> 'a -> 'a) -> ('a -> 'b -> constr -> 'b) ->
     'a -> 'b -> constr -> 'b
 
 val iter_constr_with_full_binders :
-  (rel_declaration -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a ->
+  (Context.Rel.Declaration.t -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a ->
     constr -> unit
 
 (**********************************************************************)
@@ -98,6 +96,7 @@ val strip_head_cast : constr -> constr
 val drop_extra_implicit_args : constr -> constr
 
 (** occur checks *)
+
 exception Occur
 val occur_meta : types -> bool
 val occur_existential : types -> bool
@@ -106,7 +105,11 @@ val occur_evar : existential_key -> types -> bool
 val occur_var : env -> Id.t -> types -> bool
 val occur_var_in_decl :
   env ->
-  Id.t -> 'a * types option * types -> bool
+  Id.t -> Context.Named.Declaration.t -> bool
+
+(** As {!occur_var} but assume the identifier not to be a section variable *)
+val local_occur_var : Id.t -> types -> bool
+
 val free_rels : constr -> Int.Set.t
 
 (** [dependent m t] tests whether [m] is a subterm of [t] *)
@@ -114,10 +117,11 @@ 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 dependent_in_decl : constr -> Context.Named.Declaration.t -> bool
 val count_occurrences : constr -> constr -> int
 val collect_metas : constr -> int list
 val collect_vars : constr -> Id.Set.t (** for visible vars only *)
+val vars_of_global_reference : env -> Globnames.global_reference -> Id.Set.t
 val occur_term : constr -> constr -> bool (** Synonymous
  of dependent 
    Substitution of metavariables *)
@@ -134,7 +138,7 @@ val pop : constr -> constr
 (** Substitution of an arbitrary large term. Uses equality modulo
    reduction of let *)
 
-(** [subst_term_gen eq d c] replaces [Rel 1] by [d] in [c] using [eq]
+(** [subst_term_gen eq d c] replaces [d] by [Rel 1] in [c] using [eq]
    as equality *)
 val subst_term_gen :
   (constr -> constr -> bool) -> constr -> constr -> constr
@@ -145,7 +149,7 @@ val replace_term_gen :
   (constr -> constr -> bool) ->
     constr -> constr -> constr -> constr
 
-(** [subst_term d c] replaces [Rel 1] by [d] in [c] *)
+(** [subst_term d c] replaces [d] by [Rel 1] in [c] *)
 val subst_term : constr -> constr -> constr
 
 (** [replace_term d e c] replaces [d] by [e] in [c] *)
@@ -168,11 +172,21 @@ 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) Evar.Map.t
-val filtering : rel_context -> Reduction.conv_pb -> constr -> constr -> subst
+type subst = (Context.Rel.t * constr) Evar.Map.t
+val filtering : Context.Rel.t -> Reduction.conv_pb -> constr -> constr -> subst
+
+val decompose_prod_letin : constr -> int * Context.Rel.t * constr
+val align_prod_letin : constr -> constr -> Context.Rel.t * constr
 
-val decompose_prod_letin : constr -> int * rel_context * constr
-val align_prod_letin : constr -> constr -> rel_context * constr
+(** [nb_lam] {% $ %}[x_1:T_1]...[x_n:T_n]c{% $ %} where {% $ %}c{% $ %} is not an abstraction
+   gives {% $ %}n{% $ %} (casts are ignored) *)
+val nb_lam : constr -> int
+
+(** Similar to [nb_lam], but gives the number of products instead *)
+val nb_prod : constr -> int
+
+(** Similar to [nb_prod], but zeta-contracts let-in on the way *)
+val nb_prod_modulo_zeta : constr -> int
 
 (** Get the last arg of a constr intended to be an application *)
 val last_arg : constr -> constr
@@ -191,44 +205,51 @@ 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 -> Id.t list
-val ids_of_named_context : named_context -> Id.t list
+val ids_of_rel_context : Context.Rel.t -> Id.t list
+val ids_of_named_context : Context.Named.t -> 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
+(* [context_chop n Γ] returns (Γ₁,Γ₂) such that [Γ]=[Γ₂Γ₁], [Γ₁] has
+   [n] hypotheses, excluding local definitions, and [Γ₁], if not empty,
+   starts with an hypothesis (i.e. [Γ₁] has the form empty or [x:A;Γ₁'] *)
+val context_chop : int -> Context.Rel.t -> Context.Rel.t * Context.Rel.t
+
+(* [env_rel_context_chop n env] extracts out the [n] top declarations
+   of the rel_context part of [env], counting both local definitions and
+   hypotheses *)
+val env_rel_context_chop : int -> env -> env * Context.Rel.t
 
 (** Set of local names *)
 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.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 *)
-val adjust_subst_to_rel_context : rel_context -> constr list -> constr list
+val process_rel_context : (Context.Rel.Declaration.t -> env -> env) -> env -> env
+val assums_of_rel_context : Context.Rel.t -> (Name.t * constr) list
+val lift_rel_context : int -> Context.Rel.t -> Context.Rel.t
+val substl_rel_context : constr list -> Context.Rel.t -> Context.Rel.t
+val smash_rel_context : Context.Rel.t -> Context.Rel.t (** expand lets in context *)
+
 val map_rel_context_in_env :
-  (env -> constr -> constr) -> env -> rel_context -> rel_context
+  (env -> constr -> constr) -> env -> Context.Rel.t -> Context.Rel.t
 val map_rel_context_with_binders :
-  (int -> constr -> constr) -> rel_context -> rel_context
+  (int -> constr -> constr) -> Context.Rel.t -> Context.Rel.t
 val fold_named_context_both_sides :
-  ('a -> named_declaration -> named_declaration list -> 'a) ->
-    named_context -> init:'a -> 'a
-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
+  ('a -> Context.Named.Declaration.t -> Context.Named.Declaration.t list -> 'a) ->
+    Context.Named.t -> init:'a -> 'a
+val mem_named_context_val : Id.t -> named_context_val -> bool
+val compact_named_context : Context.Named.t -> Context.NamedList.t
+val compact_named_context_reverse : Context.Named.t -> Context.NamedList.t
 
 val clear_named_body : Id.t -> env -> env
 
 val global_vars : env -> constr -> Id.t list
-val global_vars_set_of_decl : env -> named_declaration -> Id.Set.t
+val global_vars_set_of_decl : env -> Context.Named.Declaration.t -> Id.Set.t
 
 (** Gives an ordered list of hypotheses, closed by dependencies,
    containing a given set *)
-val dependency_closure : env -> named_context -> Id.Set.t -> Id.t list
+val dependency_closure : env -> Context.Named.t -> Id.Set.t -> Id.t list
 
 (** Test if an identifier is the basename of a global reference *)
 val is_section_variable : Id.t -> bool
diff --git a/engine/uState.ml b/engine/uState.ml
new file mode 100644
index 00000000..c35f97b2
--- /dev/null
+++ b/engine/uState.ml
@@ -0,0 +1,496 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - 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 CErrors
+open Util
+open Names
+
+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
+
+type uinfo = {
+  uname : string option;
+  uloc : Loc.t option;
+}
+
+(* 2nd part used to check consistency on the fly. *)
+type t =
+ { uctx_names : Univ.Level.t UNameMap.t * uinfo 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 inferred types only. *)
+   uctx_universes : UGraph.t; (** The current graph extended with the local constraints *)
+   uctx_initial_universes : UGraph.t; (** The graph at the creation of the evar_map *)
+ }
+  
+let empty =
+  { 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 = UGraph.initial_universes;
+    uctx_initial_universes = UGraph.initial_universes; }
+
+let make u =
+    { empty with 
+      uctx_universes = u; uctx_initial_universes = u}
+
+let is_empty ctx =
+  Univ.ContextSet.is_empty ctx.uctx_local && 
+    Univ.LMap.is_empty ctx.uctx_univ_variables
+
+let union ctx ctx' =
+  if ctx == ctx' then ctx
+  else if is_empty 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 newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local)
+                               (Univ.ContextSet.levels ctx.uctx_local) in
+    let newus = Univ.LSet.diff newus (Univ.LMap.domain ctx.uctx_univ_variables) in
+    let declarenew g =
+      Univ.LSet.fold (fun u g -> UGraph.add_universe u false g) newus g
+    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 = declarenew 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
+            UGraph.merge_constraints cstrsr (declarenew ctx.uctx_universes) }
+
+let context_set ctx = ctx.uctx_local
+
+let constraints ctx = snd ctx.uctx_local
+
+let context ctx = Univ.ContextSet.to_context ctx.uctx_local
+
+let of_context_set ctx = { empty with uctx_local = ctx }
+
+let subst ctx = ctx.uctx_univ_variables
+
+let ugraph ctx = ctx.uctx_universes
+
+let algebraics ctx = ctx.uctx_univ_algebraic
+
+let constrain_variables diff ctx =
+  Univ.LSet.fold
+    (fun l cstrs ->
+      try
+        match Univ.LMap.find l ctx.uctx_univ_variables with
+        | Some u -> Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs
+        | None -> cstrs
+      with Not_found | Option.IsNone -> cstrs)
+    diff Univ.Constraint.empty
+
+let add_uctx_names ?loc s l (names, names_rev) =
+  (UNameMap.add s l names, Univ.LMap.add l { uname = Some s; uloc = loc } names_rev)
+
+let add_uctx_loc l loc (names, names_rev) =
+  match loc with
+  | None -> (names, names_rev)
+  | Some _ -> (names, Univ.LMap.add l { uname = None; uloc = loc } names_rev)
+
+let of_binders b =
+  let ctx = empty in
+  let names =
+    List.fold_left (fun acc (id, l) -> add_uctx_names (Id.to_string id) l acc)
+                   ctx.uctx_names b
+  in { ctx with uctx_names = names }
+
+let instantiate_variable l b v =
+  try v := Univ.LMap.update l (Some b) !v
+  with Not_found -> assert false
+
+exception UniversesDiffer
+
+let process_universe_constraints ctx cstrs =
+  let univs = ctx.uctx_universes in
+  let vars = ref ctx.uctx_univ_variables 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 ctx.uctx_univ_algebraic)
+        in
+          if d == Universes.ULe then
+            if UGraph.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
+                        unify_universes fo (Univ.Universe.make l) Universes.UEq 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 (UGraph.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
+            | Inr (l, loc, alg), Inl r
+            | Inl r, Inr (l, loc, alg) ->
+               let inst = Univ.univ_level_rem l r r in
+                 if alg then (instantiate_variable l inst vars; local)
+                 else
+                   let lu = Univ.Universe.make l in
+                   if Univ.univ_level_mem l r then
+                     Univ.enforce_leq inst lu local
+                   else raise (Univ.UniverseInconsistency (Univ.Eq, lu, r, None))
+            | _, _ (* One of the two is algebraic or global *) -> 
+             if UGraph.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 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 cstrs' in
+    { ctx with uctx_local = (univs, Univ.Constraint.union local local');
+      uctx_univ_variables = vars;
+      uctx_universes = UGraph.merge_constraints local' 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 ctx cstrs =
+  let univs, local = ctx.uctx_local in
+  let vars, local' = process_universe_constraints ctx cstrs in
+    { ctx with uctx_local = (univs, Univ.Constraint.union local local');
+      uctx_univ_variables = vars;
+      uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes }
+
+let pr_uctx_level uctx = 
+  let map, map_rev = uctx.uctx_names in 
+    fun l ->
+      try str (Option.get (Univ.LMap.find l map_rev).uname)
+      with Not_found | Option.IsNone ->
+        Universes.pr_with_global_universes l
+
+let universe_context ?names ctx =
+  match names with
+  | None -> [], Univ.ContextSet.to_context ctx.uctx_local
+  | Some pl ->
+     let levels = Univ.ContextSet.levels ctx.uctx_local in
+     let newinst, map, left =
+       List.fold_right
+         (fun (loc,id) (newinst, map, acc) ->
+          let l =
+            try UNameMap.find (Id.to_string id) (fst ctx.uctx_names)
+            with Not_found ->
+              user_err_loc (loc, "universe_context",
+                            str"Universe " ++ Nameops.pr_id id ++ str" is not bound anymore.")
+          in (l :: newinst, (id, l) :: map, Univ.LSet.remove l acc))
+         pl ([], [], levels)
+     in
+       if not (Univ.LSet.is_empty left) then
+         let n = Univ.LSet.cardinal left in
+         let loc =
+           try
+             let info =
+               Univ.LMap.find (Univ.LSet.choose left) (snd ctx.uctx_names) in
+             Option.default Loc.ghost info.uloc
+           with Not_found -> Loc.ghost
+         in
+           user_err_loc (loc, "universe_context",
+			(str(CString.plural n "Universe") ++ spc () ++
+			     Univ.LSet.pr (pr_uctx_level ctx) left ++
+			   spc () ++ str (CString.conjugate_verb_to_be n) ++
+                           str" unbound."))
+      else
+        let inst = Univ.Instance.of_array (Array.of_list newinst) in
+        let ctx = Univ.UContext.make (inst,
+          Univ.ContextSet.constraints ctx.uctx_local)
+        in map, ctx
+
+let restrict ctx vars =
+  let uctx' = Universes.restrict_universe_context ctx.uctx_local vars in
+  { ctx with uctx_local = uctx' }
+
+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 merge ?loc sideff rigid uctx ctx' =
+  let open Univ in
+  let levels = ContextSet.levels ctx' in
+  let uctx = if sideff then uctx else
+    match rigid with
+    | UnivRigid -> uctx
+    | UnivFlexible b ->
+      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 =
+    if sideff then uctx.uctx_local
+    else ContextSet.append ctx' uctx.uctx_local
+  in
+  let declare g =
+    LSet.fold (fun u g ->
+               try UGraph.add_universe u false g
+               with UGraph.AlreadyDeclared when sideff -> g)
+              levels g
+  in
+  let uctx_names =
+    let fold u accu =
+      let modify _ info = match info.uloc with
+      | None -> { info with uloc = loc }
+      | Some _ -> info
+      in
+      try LMap.modify u modify accu
+      with Not_found -> LMap.add u { uname = None; uloc = loc } accu
+    in
+    (fst uctx.uctx_names, LSet.fold fold levels (snd uctx.uctx_names))
+  in
+  let initial = declare uctx.uctx_initial_universes in
+  let univs = declare uctx.uctx_universes in
+  let uctx_universes = UGraph.merge_constraints (ContextSet.constraints ctx') univs in
+  { uctx with uctx_names; uctx_local; uctx_universes;
+              uctx_initial_universes = initial }
+
+let merge_subst uctx s =
+  { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s }
+
+let emit_side_effects eff u =
+  let uctxs = Safe_typing.universes_of_private eff in
+  List.fold_left (merge true univ_rigid) u uctxs
+
+let new_univ_variable ?loc 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', pred =
+    match rigid with
+    | UnivRigid -> uctx, true
+    | 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}, false
+        else {uctx with uctx_univ_variables = uvars'}, false
+  in
+  let names = 
+    match name with
+    | Some n -> add_uctx_names ?loc n u uctx.uctx_names
+    | None -> add_uctx_loc u loc uctx.uctx_names
+  in
+  let initial =
+    UGraph.add_universe u false uctx.uctx_initial_universes
+  in                                                 
+  let uctx' =
+    {uctx' with uctx_names = names; uctx_local = ctx';
+                uctx_universes = UGraph.add_universe u false uctx.uctx_universes;
+                uctx_initial_universes = initial}
+  in uctx', u
+
+let add_global_univ uctx u =
+  let initial =
+    UGraph.add_universe u true uctx.uctx_initial_universes
+  in
+  let univs = 
+    UGraph.add_universe u true uctx.uctx_universes
+  in
+  { uctx with uctx_local = Univ.ContextSet.add_universe u uctx.uctx_local;
+                                     uctx_initial_universes = initial;
+                                     uctx_universes = univs }
+
+let make_flexible_variable ctx b u =
+  let {uctx_univ_variables = uvars; uctx_univ_algebraic = avars} = ctx 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
+  {ctx with uctx_univ_variables = uvars'; 
+      uctx_univ_algebraic = avars'}
+
+let is_sort_variable uctx s = 
+  match s with 
+  | Sorts.Type u -> 
+    (match Univ.universe_level u with
+    | Some l as x -> 
+        if Univ.LSet.mem l (Univ.ContextSet.levels uctx.uctx_local) then x
+        else None
+    | None -> None)
+  | _ -> None
+
+let subst_univs_context_with_def def usubst (ctx, cst) =
+  (Univ.LSet.diff ctx def, Univ.subst_univs_constraints usubst cst)
+
+let normalize_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 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 fix_undefined_variables uctx =
+  let algs', vars' = 
+    Univ.LMap.fold (fun u v (algs, vars as acc) ->
+      if v == None then (Univ.LSet.remove u algs, Univ.LMap.remove u vars)
+      else acc)
+      uctx.uctx_univ_variables 
+      (uctx.uctx_univ_algebraic, uctx.uctx_univ_variables)
+  in
+  { uctx with uctx_univ_variables = vars';
+    uctx_univ_algebraic = algs' }
+
+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 declare g = Univ.LSet.fold (fun u g -> UGraph.add_universe u false g)
+                                   (Univ.ContextSet.levels ctx') g in
+  let initial = declare uctx.uctx_initial_universes in
+  let univs = declare UGraph.initial_universes in
+  let uctx' = {uctx_names = uctx.uctx_names;
+               uctx_local = ctx'; 
+               uctx_univ_variables = vars; uctx_univ_algebraic = alg;
+               uctx_universes = univs;
+               uctx_initial_universes = initial } in
+    uctx', subst
+
+let normalize uctx = 
+  let ((vars',algs'), us') = 
+    Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables
+				    uctx.uctx_univ_algebraic
+  in
+  if Univ.ContextSet.equal us' uctx.uctx_local then uctx
+  else
+    let us', universes =
+      Universes.refresh_constraints uctx.uctx_initial_universes us'
+    in
+      { 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 }
+
+let universe_of_name uctx s = 
+  UNameMap.find s (fst uctx.uctx_names)
+
+let add_universe_name uctx s l =
+  let names' = add_uctx_names s l uctx.uctx_names in
+  { uctx with uctx_names = names' }
+
+let update_sigma_env uctx env =
+  let univs = Environ.universes env in
+  let eunivs =
+    { uctx with uctx_initial_universes = univs;
+                         uctx_universes = univs }
+  in
+  merge true univ_rigid eunivs eunivs.uctx_local
diff --git a/engine/uState.mli b/engine/uState.mli
new file mode 100644
index 00000000..0cdc6277
--- /dev/null
+++ b/engine/uState.mli
@@ -0,0 +1,119 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - 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 universe unification states which are part of evarmaps.
+    Most of the API below is reexported in {!Evd}. Consider using higher-level
+    primitives when needed. *)
+
+open Names
+
+exception UniversesDiffer
+
+type t
+(** Type of universe unification states. They allow the incremental building of
+    universe constraints during an interactive proof. *)
+
+(** {5 Constructors} *)
+
+val empty : t
+
+val make : UGraph.t -> t
+
+val is_empty : t -> bool
+
+val union : t -> t -> t
+
+val of_context_set : Univ.universe_context_set -> t
+
+val of_binders : Universes.universe_binders -> t
+
+(** {5 Projections} *)
+
+val context_set : t -> Univ.universe_context_set
+(** The local context of the state, i.e. a set of bound variables together
+    with their associated constraints. *)
+
+val subst : t -> Universes.universe_opt_subst
+(** The local universes that are unification variables *)
+
+val ugraph : t -> UGraph.t
+(** The current graph extended with the local constraints *)
+
+val algebraics : t -> Univ.LSet.t
+(** The subset of unification variables that can be instantiated with algebraic
+    universes as they appear in inferred types only. *)
+
+val constraints : t -> Univ.constraints
+(** Shorthand for {!context_set} composed with {!ContextSet.constraints}. *)
+
+val context : t -> Univ.universe_context
+(** Shorthand for {!context_set} with {!Context_set.to_context}. *)
+
+(** {5 Constraints handling} *)
+
+val add_constraints : t -> Univ.constraints -> t
+(**
+  @raise UniversesDiffer when universes differ
+*)
+
+val add_universe_constraints : t -> Universes.universe_constraints -> t
+(**
+  @raise UniversesDiffer when universes differ
+*)
+
+(** {5 Names} *)
+
+val add_universe_name : t -> string -> Univ.Level.t -> t
+(** Associate a human-readable name to a local variable. *)
+
+val universe_of_name : t -> string -> Univ.Level.t
+(** Retrieve the universe associated to the name. *)
+
+(** {5 Unification} *)
+
+val restrict : t -> Univ.universe_set -> t
+
+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
+
+val merge : ?loc:Loc.t -> bool -> rigid -> t -> Univ.universe_context_set -> t
+val merge_subst : t -> Universes.universe_opt_subst -> t
+val emit_side_effects : Safe_typing.private_constants -> t -> t
+
+val new_univ_variable : ?loc:Loc.t -> rigid -> string option -> t -> t * Univ.Level.t
+val add_global_univ : t -> Univ.Level.t -> t
+val make_flexible_variable : t -> bool -> Univ.Level.t -> t
+
+val is_sort_variable : t -> Sorts.t -> Univ.Level.t option
+
+val normalize_variables : t -> Univ.universe_subst * t
+
+val constrain_variables : Univ.LSet.t -> t -> Univ.constraints
+
+val abstract_undefined_variables : t -> t
+
+val fix_undefined_variables : t -> t
+
+val refresh_undefined_univ_variables : t -> t * Univ.universe_level_subst
+
+val normalize : t -> t
+
+(** {5 TODO: Document me} *)
+
+val universe_context : ?names:(Id.t Loc.located) list -> t -> (Id.t * Univ.Level.t) list * Univ.universe_context
+
+val update_sigma_env : t -> Environ.env -> t
+
+(** {5 Pretty-printing} *)
+
+val pr_uctx_level : t -> Univ.Level.t -> Pp.std_ppcmds
diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4
deleted file mode 100644
index 8def9537..00000000
--- a/grammar/argextend.ml4
+++ /dev/null
@@ -1,299 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \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/argextend.mlp b/grammar/argextend.mlp
new file mode 100644
index 00000000..d0ab5d80
--- /dev/null
+++ b/grammar/argextend.mlp
@@ -0,0 +1,254 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Q_util
+open GramCompat
+
+let loc = CompatLoc.ghost
+let default_loc = <:expr< Loc.ghost >>
+
+let mk_extraarg loc s = <:expr< $lid:"wit_"^s$ >>
+
+let rec make_wit loc = function
+  | 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 is_self s = function
+| ExtraArgType s' -> s = s'
+| _ -> false
+
+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 make_act loc act pil =
+  let rec make = function
+    | [] -> <:expr< (fun loc -> $act$) >>
+    | ExtNonTerminal (_, p) :: tl -> <:expr< (fun $lid:p$ -> $make tl$) >>
+    | ExtTerminal _ :: tl ->
+	<:expr< (fun _ -> $make tl$) >> in
+  make (List.rev pil)
+
+let make_prod_item = function
+  | ExtTerminal s -> <:expr< Extend.Atoken (CLexer.terminal $mlexpr_of_string s$) >>
+  | ExtNonTerminal (g, _) ->
+    let base s = <:expr< $lid:s$ >> in
+    mlexpr_of_prod_entry_key base g
+
+let rec make_prod = function
+| [] -> <:expr< Extend.Stop >>
+| item :: prods -> <:expr< Extend.Next $make_prod prods$ $make_prod_item item$ >>
+
+let make_rule loc (prods,act) =
+  <:expr< Extend.Rule $make_prod (List.rev prods)$ $make_act loc act prods$ >>
+
+let is_ident x = function
+| <:expr< $lid:s$ >> -> (s : string) = x
+| _ -> false
+
+let make_extend loc s cl wit = match cl with
+| [[ExtNonTerminal (Uentry e, id)], act] when is_ident id act ->
+  (** Special handling of identity arguments by not redeclaring an entry *)
+  <:str_item<
+    value $lid:s$ =
+      let () = Pcoq.register_grammar $wit$ $lid:e$ in
+      $lid:e$
+  >>
+| _ ->
+  let se = mlexpr_of_string s in
+  let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in
+  <:str_item<
+    value $lid:s$ =
+      let $lid:s$ = Pcoq.create_generic_entry Pcoq.utactic $se$ (Genarg.rawwit $wit$) in
+      let () = Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]) in
+      $lid:s$ >>
+
+let warning_redundant prefix s =
+  Printf.eprintf "Redundant [%sTYPED AS] clause in [ARGUMENT EXTEND %s].\n%!" prefix s
+
+let get_type prefix s = function
+| None -> None
+| Some typ ->
+  if is_self s typ then
+    let () = warning_redundant prefix s in None
+  else Some typ
+
+let check_type prefix s = function
+| None -> ()
+| Some _ -> warning_redundant prefix s
+
+let declare_tactic_argument loc s (typ, f, g, h) cl =
+  let se = mlexpr_of_string s in
+  let rawtyp, rawpr, globtyp, globpr, typ, pr = match typ with
+    | `Uniform (typ, pr) ->
+      let typ = get_type "" s typ in
+      typ, pr, typ, pr, typ, pr
+    | `Specialized (a, rpr, c, gpr, e, tpr) ->
+      (** Check that we actually need the TYPED AS arguments *)
+      let rawtyp = get_type "RAW_" s a in
+      let glbtyp = get_type "GLOB_" s c in
+      let toptyp = get_type "" s e in
+      let () = match g with None -> () | Some _ -> check_type "RAW_" s rawtyp in
+      let () = match f, h with Some _, Some _ -> check_type "GLOB_" s glbtyp | _ -> () in
+      rawtyp, rpr, glbtyp, gpr, toptyp, tpr
+  in
+  let glob = match g with
+    | None ->
+      begin match rawtyp with
+      | None -> <:expr< fun ist v -> (ist, v) >>
+      | Some rawtyp ->
+        <: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
+      | None ->
+        let typ = match globtyp with None -> ExtraArgType s | Some typ -> typ in
+        <:expr< fun ist v -> Ftactic.return (Geninterp.Val.inject (Geninterp.val_tag $make_topwit loc typ$) v) >>
+      | Some globtyp ->
+        <:expr< fun ist x ->
+          Tacinterp.interp_genarg ist (Genarg.in_gen $make_globwit loc globtyp$ x) >>
+      end
+    | Some f ->
+      (** Compatibility layer, TODO: remove me *)
+      let typ = match globtyp with None -> ExtraArgType s | Some typ -> typ in
+      <:expr<
+        let f = $lid:f$ in
+        fun ist v -> Ftactic.nf_s_enter { Proofview.Goal.s_enter = fun gl ->
+          let (sigma, v) = Tacmach.New.of_old (fun gl -> f ist gl v) gl in
+          let v = Geninterp.Val.inject (Geninterp.val_tag $make_topwit loc typ$) v in
+          Sigma.Unsafe.of_pair (Ftactic.return v, sigma)
+        }
+      >> in
+  let subst = match h with
+    | None ->
+      begin match globtyp with
+      | None -> <:expr< fun s v -> v >>
+      | Some globtyp ->
+        <: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 dyn = match typ with
+  | None -> <:expr< None >>
+  | Some typ -> <:expr< Some (Geninterp.val_tag $make_topwit loc typ$) >>
+  in
+  let wit = <:expr< $lid:"wit_"^s$ >> in
+  declare_str_items loc
+   [ <:str_item< value ($lid:"wit_"^s$) = Genarg.make0 $se$ >>;
+     <:str_item< Genintern.register_intern0 $wit$ $glob$ >>;
+     <:str_item< Genintern.register_subst0 $wit$ $subst$ >>;
+     <:str_item< Geninterp.register_interp0 $wit$ $interp$ >>;
+     <:str_item< Geninterp.register_val0 $wit$ $dyn$ >>;
+     make_extend loc s cl wit;
+     <:str_item< do {
+      Pptactic.declare_extra_genarg_pprule
+        $wit$ $lid:rawpr$ $lid:globpr$ $lid:pr$;
+      Tacentries.create_ltac_quotation $se$
+        (fun (loc, v) -> Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit $wit$) v))
+        ($lid:s$, None)
+      } >> ]
+
+let declare_vernac_argument loc s pr cl =
+  let se = mlexpr_of_string s in
+  let wit = <:expr< $lid:"wit_"^s$ >> 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 $se$ >>;
+     make_extend loc s cl wit;
+    <:str_item< do {
+      Pptactic.declare_extra_genarg_pprule $wit$
+        $pr_rules$
+        (fun _ _ _ _ -> CErrors.anomaly (Pp.str "vernac argument needs not globwit printer"))
+        (fun _ _ _ _ -> CErrors.anomaly (Pp.str "vernac argument needs not wit printer")) }
+      >> ]
+
+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_specialized:
+  [ [ rawtyp = OPT [ "RAW_TYPED"; "AS"; rawtyp = argtype -> rawtyp ];
+      "RAW_PRINTED"; "BY"; rawpr = LIDENT;
+      globtyp = OPT [ "GLOB_TYPED"; "AS"; globtyp = argtype -> globtyp ];
+      "GLOB_PRINTED"; "BY"; globpr = LIDENT ->
+      (rawtyp, rawpr, globtyp, globpr) ] ]
+  ;
+  argextend_header:
+    [ [ typ = OPT [ "TYPED"; "AS"; typ = argtype -> typ ];
+        "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 ];
+        special = OPT argextend_specialized ->
+        let repr = match special with
+        | None -> `Uniform (typ, pr)
+        | Some (rtyp, rpr, gtyp, gpr) -> `Specialized (rtyp, rpr, gtyp, gpr, typ, pr)
+        in
+        (repr, 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 ->
+        let e = parse_user_entry e "" in
+        type_of_user_symbol e
+      | "("; e = argtype; ")" -> e ] ]
+  ;
+  argrule:
+    [ [ "["; l = LIST0 genarg; "]"; "->"; "["; e = Pcaml.expr; "]" -> (l,e) ] ]
+  ;
+  genarg:
+    [ [ e = LIDENT; "("; s = LIDENT; ")" ->
+        let e = parse_user_entry e "" in
+        ExtNonTerminal (e, s)
+      | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" ->
+        let e = parse_user_entry e sep in
+        ExtNonTerminal (e, s)
+      | s = STRING -> ExtTerminal s
+    ] ]
+  ;
+  entry_name:
+    [ [ s = LIDENT -> s
+      | UIDENT -> failwith "Argument entry names must be lowercase"
+      ] ]
+  ;
+  END
diff --git a/tools/compat5.ml b/grammar/compat5.ml
index 33c1cd60..33c1cd60 100644
--- a/tools/compat5.ml
+++ b/grammar/compat5.ml
diff --git a/tools/compat5.mlp b/grammar/compat5.mlp
index 8473a1fb..8473a1fb 100644
--- a/tools/compat5.mlp
+++ b/grammar/compat5.mlp
diff --git a/tools/compat5b.mlp b/grammar/compat5b.mlp
index 46802a82..46802a82 100644
--- a/tools/compat5b.mlp
+++ b/grammar/compat5b.mlp
diff --git a/grammar/gramCompat.mlp b/grammar/gramCompat.mlp
new file mode 100644
index 00000000..6246da7b
--- /dev/null
+++ b/grammar/gramCompat.mlp
@@ -0,0 +1,86 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Compatibility file depending on ocaml/camlp4 version *)
+
+(** Misc module emulation *)
+
+IFDEF CAMLP5 THEN
+
+module CompatLoc = struct
+  include Ploc
+  let ghost = dummy
+  let merge = encl
+end
+
+ELSE
+
+module CompatLoc = Camlp4.PreCast.Loc
+
+END
+
+IFDEF CAMLP5 THEN
+
+module PcamlSig = struct end
+
+ELSE
+
+module PcamlSig = Camlp4.Sig
+module Ast = Camlp4.PreCast.Ast
+module Pcaml = Camlp4.PreCast.Syntax
+module MLast = Ast
+
+END
+
+(** Compatibility with camlp5 strict mode *)
+IFDEF CAMLP5 THEN
+  IFDEF STRICT THEN
+    let vala x = Ploc.VaVal x
+  ELSE
+    let vala x = x
+  END
+ELSE
+  let vala x = x
+END
+
+(** Fix a quotation difference in [str_item] *)
+
+let declare_str_items loc l =
+IFDEF CAMLP5 THEN
+  MLast.StDcl (loc, vala l) (* correspond to <:str_item< declare $list:l'$ end >> *)
+ELSE
+  Ast.stSem_of_list l
+END
+
+(** Quotation difference for match clauses *)
+
+let default_patt loc =
+  (<:patt< _ >>, vala None, <:expr< failwith "Extension: cannot occur" >>)
+
+IFDEF CAMLP5 THEN
+
+let make_fun loc cl =
+  let l = cl @ [default_patt loc] in
+  MLast.ExFun (loc, vala l)  (* correspond to <:expr< fun [ $list:l$ ] >> *)
+
+ELSE
+
+let make_fun loc cl =
+  let mk_when = function
+    | Some w -> w
+    | None -> Ast.ExNil loc
+  in
+  let mk_clause (patt,optwhen,expr) =
+    (* correspond to <:match_case< ... when ... -> ... >> *)
+    Ast.McArr (loc, patt, mk_when optwhen, expr) in
+  let init = mk_clause (default_patt loc) in
+  let add_clause x acc = Ast.McOr (loc, mk_clause x, acc) in
+  let l = List.fold_right add_clause cl init in
+  Ast.ExFun (loc,l) (* correspond to <:expr< fun [ $l$ ] >> *)
+
+END
diff --git a/grammar/grammar.mllib b/grammar/grammar.mllib
deleted file mode 100644
index 71e5b8ae..00000000
--- a/grammar/grammar.mllib
+++ /dev/null
@@ -1,65 +0,0 @@
-Coq_config
-
-Hook
-Terminal
-Canary
-Hashset
-Hashcons
-CSet
-CMap
-Int
-HMap
-Option
-Store
-Exninfo
-Backtrace
-Pp_control
-Flags
-Loc
-CList
-CString
-Serialize
-Stateid
-Feedback
-Pp
-
-CArray
-CStack
-Util
-Ppstyle
-Errors
-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/grammar/q_constr.ml4 b/grammar/q_constr.ml4
deleted file mode 100644
index 40db8194..00000000
--- a/grammar/q_constr.ml4
+++ /dev/null
@@ -1,120 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \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 Q_util
-open Compat
-open Pcaml
-open PcamlSig (* necessary for camlp4 *)
-
-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$, None), $mlexpr_of_list (fun x -> x) l$)
-  >>
-
-EXTEND
-  GLOBAL: expr;
-  expr:
-    [ [ "PATTERN"; "["; c = constr; "]" ->
-      <:expr< snd (Patternops.pattern_of_glob_constr $c$) >> ] ]
-  ;
-  sort:
-    [ [ "Set"  -> Misctypes.GSet
-      | "Prop" -> Misctypes.GProp
-      | "Type" -> Misctypes.GType [] ] ]
-  ;
-  ident:
-    [ [ s = string -> <:expr< Names.Id.of_string $str:s$ >> ] ]
-  ;
-  name:
-    [ [ "_" -> <:expr< Anonymous >> | id = ident -> <:expr< Name $id$ >> ] ]
-  ;
-  string:
-    [ [ s = UIDENT -> s | s = LIDENT -> s ] ]
-  ;
-  constr:
-    [ "200" RIGHTA
-      [ LIDENT "forall"; id = ident; ":"; c1 = constr; ","; c2 = constr ->
-        <: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$,Decl_kinds.Explicit,$c1$,$c2$) >>
-      | "let"; id = ident; ":="; c1 = constr; "in"; c2 = constr ->
-        <:expr< Glob_term.RLetin ($dloc$,Name $id$,$c1$,$c2$) >>
-      (* fix todo *)
-      ]
-    | "100" RIGHTA
-      [ c1 = constr; ":"; c2 = SELF ->
-        <:expr< Glob_term.GCast($dloc$,$c1$,DEFAULTcast,$c2$) >> ]
-    | "90" RIGHTA
-      [ c1 = constr; "->"; c2 = SELF ->
-        <:expr< Glob_term.GProd ($dloc$,Anonymous,Decl_kinds.Explicit,$c1$,$c2$) >> ]
-    | "75" RIGHTA
-      [ "~"; c = constr ->
-        apply_ref <:expr< coq_not_ref >> [c] ]
-    | "70" RIGHTA
-      [ c1 = constr; "="; c2 = NEXT; ":>"; t = NEXT ->
-        apply_ref <:expr< coq_eq_ref >> [t;c1;c2] ]
-    | "10" LEFTA
-      [ f = constr; args = LIST1 NEXT ->
-        let args = mlexpr_of_list (fun x -> x) args in
-        <:expr< Glob_term.GApp ($dloc$,$f$,$args$) >> ]
-    | "0"
-      [ s = sort -> <:expr< Glob_term.GSort ($dloc$,s) >>
-      | id = ident -> <:expr< Glob_term.GVar ($dloc$,$id$) >>
-      | "_" -> <: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$, None) >>
-      | c = match_constr -> c
-      | "("; c = constr LEVEL "200"; ")" -> c ] ]
-  ;
-  match_constr:
-    [ [ "match"; c = constr LEVEL "100"; (ty,nal) = match_type;
-        "with"; OPT"|"; br = LIST0 eqn SEP "|"; "end" ->
-          let br = mlexpr_of_list (fun x -> x) br in
-     <:expr< Glob_term.GCases ($dloc$,$ty$,[($c$,$nal$)],$br$) >>
-    ] ]
-  ;
-  match_type:
-    [ [ "as"; id = ident; "in"; ind = LIDENT; nal = LIST0 name;
-        "return"; ty = constr LEVEL "100" ->
-          let nal = mlexpr_of_list (fun x -> x) nal in
-          <:expr< Some $ty$ >>,
-          <:expr< (Name $id$, Some ($dloc$,$lid:ind$,$nal$)) >>
-      | -> <:expr< None >>, <:expr< (Anonymous, None) >> ] ]
-  ;
-  eqn:
-    [ [ (lid,pl) = pattern; "=>"; rhs = constr ->
-        let lid = mlexpr_of_list (fun x -> x) lid in
-        <:expr< ($dloc$,$lid$,[$pl$],$rhs$) >>
-    ] ]
-  ;
-  pattern:
-    [ [ "%"; e = string; lip = LIST0 patvar ->
-        let lp = mlexpr_of_list (fun (_,x) -> x) lip in
-        let lid = List.flatten (List.map fst lip) in
-        lid, <:expr< Glob_term.PatCstr ($dloc$,$lid:e$,$lp$,Anonymous) >>
-      | p = patvar -> p
-      | "("; p = pattern; ")" -> p ] ]
-  ;
-  patvar:
-    [ [ "_" -> [], <:expr< Glob_term.PatVar ($dloc$,Anonymous) >>
-      | id = ident -> [id], <:expr< Glob_term.PatVar ($dloc$,Name $id$) >>
-    ] ]
-  ;
-  END;;
-
-(* Example
-open Coqlib
-let a = PATTERN [ match ?X with %path_of_S n => n | %path_of_O => ?X end ]
-*)
diff --git a/grammar/q_coqast.ml4 b/grammar/q_coqast.ml4
deleted file mode 100644
index 304e4992..00000000
--- a/grammar/q_coqast.ml4
+++ /dev/null
@@ -1,597 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Names
-open Q_util
-open Compat
-
-let is_meta s = String.length s > 0 && s.[0] == '$'
-
-let purge_str s =
-  if String.length s == 0 || s.[0] <> '$' then s
-  else String.sub s 1 (String.length s - 1)
-
-let anti loc x =
-  expl_anti loc <:expr< $lid:purge_str x$ >>
-
-(* We don't give location for tactic quotation! *)
-let loc = CompatLoc.ghost
-
-let dloc = <:expr< Loc.ghost >>
-
-let mlexpr_of_ident 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.Id.to_string id$) >>
-
-let mlexpr_of_dirpath dir =
-  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) = 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) ->
-    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_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
-  | 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
-  | 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_quantified_hypothesis = function
-  | 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
-  | 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_located mlexpr_of_ident)
-
-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, 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< {Locus.onhyps=
-             $mlexpr_of_option (mlexpr_of_list mlexpr_of_hyp_location)
-               cl.Locus.onhyps$;
-           Locus.concl_occs= $mlexpr_of_occs cl.Locus.concl_occs$} >>
-
-let mlexpr_of_red_flags {
-  Genredexpr.rBeta = bb;
-  Genredexpr.rIota = bi;
-  Genredexpr.rZeta = bz;
-  Genredexpr.rDelta = bd;
-  Genredexpr.rConst = l
-} = <:expr< {
-  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
-  | 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
-  | Decl_kinds.Implicit -> <:expr< Decl_kinds.Implicit >>
-  | Decl_kinds.Explicit -> <:expr< Decl_kinds.Explicit >>
-
-let mlexpr_of_binder_kind = function
-  | 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
-  | 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$ >>
-  | 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$,[]) >>
-  | 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
-  | 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< 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< 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.IntOrVarArgType -> <:expr< Genarg.IntOrVarArgType >>
-  | Genarg.IdentArgType -> <:expr< Genarg.IdentArgType >>
-  | Genarg.VarArgType -> <:expr< Genarg.VarArgType >>
-  | Genarg.QuantHypArgType -> <:expr< Genarg.QuantHypArgType >>
-  | Genarg.OpenConstrArgType -> <:expr< Genarg.OpenConstrArgType >>
-  | Genarg.ConstrWithBindingsArgType -> <:expr< Genarg.ConstrWithBindingsArgType >>
-  | Genarg.BindingsArgType -> <:expr< Genarg.BindingsArgType >>
-  | Genarg.RedExprArgType -> <:expr< Genarg.RedExprArgType >>
-  | Genarg.GenArgType -> <:expr< Genarg.GenArgType >>
-  | Genarg.ConstrArgType -> <:expr< Genarg.ConstrArgType >>
-  | Genarg.ConstrMayEvalArgType -> <:expr< Genarg.ConstrMayEvalArgType >>
-  | 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
-      let t2 = mlexpr_of_argtype loc t2 in
-      <:expr< Genarg.PairArgType $t1$ $t2$ >>
-  | Genarg.ExtraArgType s -> <:expr< Genarg.ExtraArgType $str:s$ >>
-
-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< 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
-  | Misctypes.ExplicitBindings l ->
-      let l = mlexpr_of_list (mlexpr_of_triple mlexpr_of_loc mlexpr_of_quantified_hypothesis mlexpr_of_constr) l in
-      <:expr< Misctypes.ExplicitBindings $l$ >>
-  | Misctypes.ImplicitBindings l ->
-      let l = mlexpr_of_list mlexpr_of_constr l in
-      <: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
-  | 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 ->
-      <:expr< Tacexpr.ElimOnConstr $mlexpr_of_constr_with_binding c$ >>
-  | Tacexpr.ElimOnIdent (_,id) ->
-      <:expr< Tacexpr.ElimOnIdent $dloc$ $mlexpr_of_ident id$ >>
-  | Tacexpr.ElimOnAnonHyp n ->
-      <:expr< Tacexpr.ElimOnAnonHyp $mlexpr_of_int n$ >>
-
-let mlexpr_of_clause_pattern _ = failwith "mlexpr_of_clause_pattern: TODO"
-
-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) ->
-      <:expr< Tacexpr.Subterm $mlexpr_of_bool b$ $mlexpr_of_option mlexpr_of_ident ido$ $mlexpr_of_pattern_ast t$ >>
-
-let mlexpr_of_match_context_hyps = function
-  | Tacexpr.Hyp (id,l) ->
-      let f = mlexpr_of_located mlexpr_of_name in
-      <:expr< Tacexpr.Hyp $f id$ $mlexpr_of_match_pattern l$ >>
-  | Tacexpr.Def (id,v,l) ->
-      let f = mlexpr_of_located mlexpr_of_name in
-      <:expr< Tacexpr.Def $f id$ $mlexpr_of_match_pattern v$ $mlexpr_of_match_pattern l$ >>
-
-let mlexpr_of_match_rule f = function
-  | Tacexpr.Pat (l,mp,t) -> <:expr< Tacexpr.Pat $mlexpr_of_list mlexpr_of_match_context_hyps l$ $mlexpr_of_match_pattern mp$ $f t$ >>
-  | Tacexpr.All t -> <:expr< Tacexpr.All $f t$ >>
-
-let mlexpr_of_message_token = function
-  | Tacexpr.MsgString s -> <:expr< Tacexpr.MsgString $str:s$ >>
-  | Tacexpr.MsgInt n -> <:expr< Tacexpr.MsgInt $mlexpr_of_int n$ >>
-  | Tacexpr.MsgIdent id -> <:expr< Tacexpr.MsgIdent $mlexpr_of_hyp id$ >>
-
-let mlexpr_of_debug = function
-  | Tacexpr.Off -> <:expr< Tacexpr.Off >>
-  | Tacexpr.Debug -> <:expr< Tacexpr.Debug >>
-  | Tacexpr.Info -> <:expr< Tacexpr.Info >>
-
-let rec mlexpr_of_atomic_tactic = function
-  (* Basic tactics *)
-  | Tacexpr.TacIntroPattern pl ->
-      let pl = mlexpr_of_list (mlexpr_of_located mlexpr_of_intro_pattern) pl in
-      <:expr< Tacexpr.TacIntroPattern $pl$ >>
-  | 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.TacExact c ->
-      <:expr< Tacexpr.TacExact $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_arg cb$ None >>
-  | Tacexpr.TacElim (false,cb,cbo) ->
-      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.TacCase (false,cb) ->
-      let cb = mlexpr_of_constr_with_binding_arg cb in
-      <:expr< Tacexpr.TacCase False $cb$ >>
-  | 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 (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 $id$ $n$ $l$ >>
-  | Tacexpr.TacCofix ido ->
-      let ido = mlexpr_of_ident_option ido in
-      <:expr< Tacexpr.TacCofix $ido$ >>
-  | 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 $id$ $l$ >>
-
-  | 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_bool b$
-              $mlexpr_of_option mlexpr_of_tactic t$ $ipat$
-	      $mlexpr_of_constr c$ >>
-  | Tacexpr.TacGeneralize cl ->
-      <:expr< Tacexpr.TacGeneralize
-	      $mlexpr_of_list
-                (mlexpr_of_pair mlexpr_of_occ_constr mlexpr_of_name) cl$ >>
-  | Tacexpr.TacGeneralizeDep c ->
-      <:expr< Tacexpr.TacGeneralizeDep $mlexpr_of_constr c$ >>
-  | Tacexpr.TacLetTac (na,c,cl,b,e) ->
-      let na = mlexpr_of_name na in
-      let cl = mlexpr_of_clause_pattern cl in
-      <:expr< Tacexpr.TacLetTac $na$ $mlexpr_of_constr c$ $cl$
-	      $mlexpr_of_bool b$
-	      (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern) e)
-      >>
-
-  (* Derived basic tactics *)
-  | Tacexpr.TacInductionDestruct (isrec,ev,l) ->
-      <:expr< Tacexpr.TacInductionDestruct $mlexpr_of_bool isrec$ $mlexpr_of_bool ev$
-	$mlexpr_of_pair
-	(mlexpr_of_list
-	   (mlexpr_of_triple
-	      (mlexpr_of_pair
-                 (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)
- l$ >>
-
-  (* Context management *)
-  | Tacexpr.TacClear (b,l) ->
-      let l = mlexpr_of_list (mlexpr_of_hyp) l in
-      <:expr< Tacexpr.TacClear $mlexpr_of_bool b$ $l$ >>
-  | Tacexpr.TacClearBody l ->
-      let l = mlexpr_of_list (mlexpr_of_hyp) l in
-      <:expr< Tacexpr.TacClearBody $l$ >>
-  | Tacexpr.TacMove (id1,id2) ->
-      <:expr< Tacexpr.TacMove
-              $mlexpr_of_hyp id1$
-              $mlexpr_of_move_location mlexpr_of_hyp id2$ >>
-
-  (* Constructors *)
-  | Tacexpr.TacSplit (ev,l) ->
-      <:expr< Tacexpr.TacSplit
-        ($mlexpr_of_bool ev$, $mlexpr_of_list mlexpr_of_binding_kind l$)>>
-  (* Conversion *)
-  | Tacexpr.TacReduce (r,cl) ->
-      let l = mlexpr_of_clause cl in
-      <:expr< Tacexpr.TacReduce $mlexpr_of_red_expr r$ $l$ >>
-  | Tacexpr.TacChange (p,c,cl) ->
-      let l = mlexpr_of_clause cl in
-      let g = mlexpr_of_option mlexpr_of_constr in
-      <:expr< Tacexpr.TacChange $g p$ $mlexpr_of_constr c$ $l$ >>
-
-  (* Equivalence relations *)
-  | Tacexpr.TacSymmetry ido -> <:expr< Tacexpr.TacSymmetry $mlexpr_of_clause ido$ >>
-
-  (* Automation tactics *)
-  | Tacexpr.TacAuto (debug,n,lems,l) ->
-      let d = mlexpr_of_debug debug in
-      let n = mlexpr_of_option (mlexpr_of_or_var mlexpr_of_int) n in
-      let lems = mlexpr_of_list mlexpr_of_constr lems in
-      let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in
-      <:expr< Tacexpr.TacAuto $d$ $n$ $lems$ $l$ >>
-  | Tacexpr.TacTrivial (debug,lems,l) ->
-      let d = mlexpr_of_debug debug in
-      let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in
-      let lems = mlexpr_of_list mlexpr_of_constr lems in
-      <:expr< Tacexpr.TacTrivial $d$ $lems$ $l$ >>
-
-  | _ -> failwith "Quotation of atomic tactic expressions: TODO"
-
-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.TacThens (t,tl) ->
-      <:expr< Tacexpr.TacThens $mlexpr_of_tactic t$ $mlexpr_of_list mlexpr_of_tactic tl$>>
-  | Tacexpr.TacFirst tl ->
-      <:expr< Tacexpr.TacFirst $mlexpr_of_list mlexpr_of_tactic tl$ >>
-  | Tacexpr.TacSolve tl ->
-      <: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) ->
-      <:expr< Tacexpr.TacDo $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_tactic t$ >>
-  | Tacexpr.TacTimeout (n,t) ->
-      <:expr< Tacexpr.TacTimeout $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_tactic t$ >>
-  | Tacexpr.TacRepeat t ->
-      <: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 (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)
-
-  | Tacexpr.TacRec (id,(idl,t)) -> TacRec (loc,(id,(idl,f t)))
-  | Tacexpr.TacRecIn (l,t) -> TacRecIn(loc,List.map (fun (id,t) -> (id,f t)) l,f t)
-*)
-  | Tacexpr.TacLetIn (isrec,l,t) ->
-      let f =
-	mlexpr_of_pair
-	  (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_ident)
-	  mlexpr_of_tactic_arg in
-      <: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_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_match_lazy_flag lz$
-        $mlexpr_of_bool lr$
-        $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>>
-
-  | Tacexpr.TacFun (idol,body) ->
-      <:expr< Tacexpr.TacFun
-        ($mlexpr_of_list mlexpr_of_ident_option idol$,
-         $mlexpr_of_tactic body$) >>
-  | Tacexpr.TacArg (_,Tacexpr.MetaIdArg (_,true,id)) -> anti loc id
-  | Tacexpr.TacArg (_,t) ->
-      <:expr< Tacexpr.TacArg $dloc$ $mlexpr_of_tactic_arg t$ >>
-  | Tacexpr.TacComplete t ->
-      <:expr< Tacexpr.TacComplete $mlexpr_of_tactic t$ >>
-  | _ -> failwith "Quotation of tactic expressions: TODO"
-
-and mlexpr_of_tactic_arg = function
-  | Tacexpr.MetaIdArg (loc,true,id) ->
-    let loc = of_coqloc loc in
-    anti loc id
-  | Tacexpr.MetaIdArg (loc,false,id) ->
-    let loc = of_coqloc loc in
-    <:expr< Tacexpr.ConstrMayEval (Genredexpr.ConstrTerm $anti loc id$) >>
-  | Tacexpr.TacCall (loc,t,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 ->
-      <:expr< Tacexpr.ConstrMayEval $mlexpr_of_may_eval mlexpr_of_constr c$ >>
-  | Tacexpr.Reference r ->
-      <:expr< Tacexpr.Reference $mlexpr_of_reference r$ >>
-  | _ -> failwith "mlexpr_of_tactic_arg: TODO"
-
-
-IFDEF CAMLP5 THEN
-
-let not_impl x =
-  let desc =
-    if Obj.is_block (Obj.repr x) then
-      "tag = " ^ string_of_int (Obj.tag (Obj.repr x))
-    else "int_val = " ^ string_of_int (Obj.magic x)
-  in
-  failwith ("<Q_coqast.patt_of_expt, not impl: " ^ desc)
-
-(* The following function is written without quotation
-   in order to be parsable even by camlp4. The version with
-   quotation can be found in revision <= 12972 of [q_util.ml4] *)
-
-open MLast
-
-let rec patt_of_expr e =
-  let loc = loc_of_expr e in
-  match e with
-    | ExAcc (_, e1, e2) -> PaAcc (loc, patt_of_expr e1, patt_of_expr e2)
-    | ExApp (_, e1, e2) -> PaApp (loc, patt_of_expr e1, patt_of_expr e2)
-    | ExLid (_, x) when x = vala "loc" -> PaAny loc
-    | ExLid (_, s) -> PaLid (loc, s)
-    | ExUid (_, s) -> PaUid (loc, s)
-    | ExStr (_, s) -> PaStr (loc, s)
-    | ExAnt (_, e) -> PaAnt (loc, patt_of_expr e)
-    | _ -> not_impl e
-
-let fconstr e =
-  let ee s =
-    mlexpr_of_constr (Pcoq.Gram.entry_parse e
-			(Pcoq.Gram.parsable (Stream.of_string s)))
-  in
-  let ep s = patt_of_expr (ee s) in
-  Quotation.ExAst (ee, ep)
-
-let ftac e =
-  let ee s =
-    mlexpr_of_tactic (Pcoq.Gram.entry_parse e
-			(Pcoq.Gram.parsable (Stream.of_string s)))
-  in
-  let ep s = patt_of_expr (ee s) in
-  Quotation.ExAst (ee, ep)
-
-let _ =
-  Quotation.add "constr" (fconstr Pcoq.Constr.constr_eoi);
-  Quotation.add "tactic" (ftac Pcoq.Tactic.tactic_eoi);
-  Quotation.default := "constr"
-
-ELSE
-
-open Pcaml
-
-let expand_constr_quot_expr loc _loc_name_opt contents =
-  mlexpr_of_constr
-    (Pcoq.Gram.parse_string Pcoq.Constr.constr_eoi loc contents)
-
-let expand_tactic_quot_expr loc _loc_name_opt contents =
-  mlexpr_of_tactic
-    (Pcoq.Gram.parse_string Pcoq.Tactic.tactic_eoi loc contents)
-
-let _ =
-  (* FIXME: for the moment, we add quotations in expressions only, not pattern *)
-  Quotation.add "constr" Quotation.DynAst.expr_tag expand_constr_quot_expr;
-  Quotation.add "tactic" Quotation.DynAst.expr_tag expand_tactic_quot_expr;
-  Quotation.default := "constr"
-
-END
diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4
deleted file mode 100644
index a116b1e8..00000000
--- a/grammar/q_util.ml4
+++ /dev/null
@@ -1,64 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* This file defines standard combinators to build ml expressions *)
-
-open Compat
-
-let mlexpr_of_list f l =
-  List.fold_right
-    (fun e1 e2 ->
-      let e1 = f e1 in
-       let loc = CompatLoc.merge (MLast.loc_of_expr e1) (MLast.loc_of_expr e2) in
-       <:expr< [$e1$ :: $e2$] >>)
-    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 = 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 = 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 = 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 = CompatLoc.ghost
-
-
-let mlexpr_of_bool = function
-  | true -> <:expr< True >>
-  | false -> <:expr< False >>
-
-let mlexpr_of_int n = <:expr< $int:string_of_int n$ >>
-
-let mlexpr_of_string s = <:expr< $str:s$ >>
-
-let mlexpr_of_option f = function
-  | None -> <:expr< None >>
-  | Some e -> <:expr< Some $f e$ >>
-
-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$ >>
-  | Pcoq.Alist0 s -> <:expr< Pcoq.Alist0 $mlexpr_of_prod_entry_key s$ >>
-  | Pcoq.Alist0sep (s,sep) -> <:expr< Pcoq.Alist0sep $mlexpr_of_prod_entry_key s$ $str:sep$ >>
-  | Pcoq.Aopt s -> <:expr< Pcoq.Aopt $mlexpr_of_prod_entry_key s$ >>
-  | Pcoq.Amodifiers s -> <:expr< Pcoq.Amodifiers $mlexpr_of_prod_entry_key s$ >>
-  | Pcoq.Aself -> <:expr< Pcoq.Aself >>
-  | Pcoq.Anext -> <:expr< Pcoq.Anext >>
-  | Pcoq.Atactic n -> <:expr< Pcoq.Atactic $mlexpr_of_int n$ >>
-  | 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/grammar/q_util.mli b/grammar/q_util.mli
index a85ad2f6..a5e36e47 100644
--- a/grammar/q_util.mli
+++ b/grammar/q_util.mli
@@ -6,7 +6,26 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Compat (* necessary for camlp4 *)
+open GramCompat (* necessary for camlp4 *)
+
+type argument_type =
+| ListArgType of argument_type
+| OptArgType of argument_type
+| PairArgType of argument_type * argument_type
+| ExtraArgType of string
+
+type user_symbol =
+| Ulist1 of user_symbol
+| Ulist1sep of user_symbol * string
+| Ulist0 of user_symbol
+| Ulist0sep of user_symbol * string
+| Uopt of user_symbol
+| Uentry of string
+| Uentryl of string * int
+
+type extend_token =
+| ExtTerminal of string
+| ExtNonTerminal of user_symbol * string
 
 val mlexpr_of_list :  ('a -> MLast.expr) -> 'a list -> MLast.expr
 
@@ -14,14 +33,6 @@ val mlexpr_of_pair :
   ('a -> MLast.expr) -> ('b -> MLast.expr)
     -> 'a * 'b -> MLast.expr
 
-val mlexpr_of_triple :
-  ('a -> MLast.expr) -> ('b -> MLast.expr) -> ('c -> MLast.expr)
-    -> 'a * 'b * 'c -> MLast.expr
-
-val mlexpr_of_quadruple :
-  ('a -> MLast.expr) -> ('b -> MLast.expr) ->
-    ('c -> MLast.expr) -> ('d -> MLast.expr) -> 'a * 'b * 'c * 'd -> MLast.expr
-
 val mlexpr_of_bool : bool -> MLast.expr
 
 val mlexpr_of_int : int -> MLast.expr
@@ -30,4 +41,8 @@ val mlexpr_of_string : string -> MLast.expr
 
 val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr
 
-val mlexpr_of_prod_entry_key : Pcoq.prod_entry_key -> MLast.expr
+val mlexpr_of_prod_entry_key : (string -> MLast.expr) -> user_symbol -> MLast.expr
+
+val type_of_user_symbol : user_symbol -> argument_type
+
+val parse_user_entry : string -> string -> user_symbol
diff --git a/grammar/q_util.mlp b/grammar/q_util.mlp
new file mode 100644
index 00000000..2d5c4089
--- /dev/null
+++ b/grammar/q_util.mlp
@@ -0,0 +1,118 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* This file defines standard combinators to build ml expressions *)
+
+open GramCompat
+
+type argument_type =
+| ListArgType of argument_type
+| OptArgType of argument_type
+| PairArgType of argument_type * argument_type
+| ExtraArgType of string
+
+type user_symbol =
+| Ulist1 of user_symbol
+| Ulist1sep of user_symbol * string
+| Ulist0 of user_symbol
+| Ulist0sep of user_symbol * string
+| Uopt of user_symbol
+| Uentry of string
+| Uentryl of string * int
+
+type extend_token =
+| ExtTerminal of string
+| ExtNonTerminal of user_symbol * string
+
+let mlexpr_of_list f l =
+  List.fold_right
+    (fun e1 e2 ->
+      let e1 = f e1 in
+       let loc = CompatLoc.merge (MLast.loc_of_expr e1) (MLast.loc_of_expr e2) in
+       <:expr< [$e1$ :: $e2$] >>)
+    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 = CompatLoc.merge (MLast.loc_of_expr e1) (MLast.loc_of_expr e2) in
+  <:expr< ($e1$, $e2$) >>
+
+(* We don't give location for tactic quotation! *)
+let loc = CompatLoc.ghost
+
+
+let mlexpr_of_bool = function
+  | true -> <:expr< True >>
+  | false -> <:expr< False >>
+
+let mlexpr_of_int n = <:expr< $int:string_of_int n$ >>
+
+let mlexpr_of_string s = <:expr< $str:s$ >>
+
+let mlexpr_of_option f = function
+  | None -> <:expr< None >>
+  | Some e -> <:expr< Some $f e$ >>
+
+let symbol_of_string s = <:expr< Extend.Atoken (CLexer.terminal $str:s$) >>
+
+let rec mlexpr_of_prod_entry_key f = function
+  | Ulist1 s -> <:expr< Extend.Alist1 $mlexpr_of_prod_entry_key f s$ >>
+  | Ulist1sep (s,sep) -> <:expr< Extend.Alist1sep $mlexpr_of_prod_entry_key f s$ $symbol_of_string sep$ >>
+  | Ulist0 s -> <:expr< Extend.Alist0 $mlexpr_of_prod_entry_key f s$ >>
+  | Ulist0sep (s,sep) -> <:expr< Extend.Alist0sep $mlexpr_of_prod_entry_key f s$ $symbol_of_string sep$ >>
+  | Uopt s -> <:expr< Extend.Aopt $mlexpr_of_prod_entry_key f s$ >>
+  | Uentry e -> <:expr< Extend.Aentry $f e$ >>
+  | Uentryl (e, l) ->
+    (** Keep in sync with Pcoq! *)
+    assert (e = "tactic");
+    if l = 5 then <:expr< Extend.Aentry (Pcoq.Tactic.binder_tactic) >>
+    else <:expr< Extend.Aentryl (Pcoq.Tactic.tactic_expr) $mlexpr_of_int l$ >>
+
+let rec type_of_user_symbol = function
+| Ulist1 s | Ulist1sep (s, _) | Ulist0 s | Ulist0sep (s, _) ->
+  ListArgType (type_of_user_symbol s)
+| Uopt s ->
+  OptArgType (type_of_user_symbol s)
+| Uentry e | Uentryl (e, _) -> ExtraArgType e
+
+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 := c = d;
+    incr i
+  done;
+  !break
+
+let rec parse_user_entry s sep =
+  let l = String.length s in
+  if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then
+    let entry = parse_user_entry (String.sub s 3 (l-8)) "" in
+    Ulist1 entry
+  else if l > 12 && coincide s "ne_" 0 &&
+                   coincide s "_list_sep" (l-9) then
+    let entry = parse_user_entry (String.sub s 3 (l-12)) "" in
+    Ulist1sep (entry, sep)
+  else if l > 5 && coincide s "_list" (l-5) then
+    let entry = parse_user_entry (String.sub s 0 (l-5)) "" in
+    Ulist0 entry
+  else if l > 9 && coincide s "_list_sep" (l-9) then
+    let entry = parse_user_entry (String.sub s 0 (l-9)) "" in
+    Ulist0sep (entry, sep)
+  else if l > 4 && coincide s "_opt" (l-4) then
+    let entry = parse_user_entry (String.sub s 0 (l-4)) "" in
+    Uopt entry
+  else if l = 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then
+    let n = Char.code s.[6] - 48 in
+    Uentryl ("tactic", n)
+  else
+    let s = match s with "hyp" -> "var" | _ -> s in
+    Uentry s
diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4
deleted file mode 100644
index 39f605e2..00000000
--- a/grammar/tacextend.ml4
+++ /dev/null
@@ -1,283 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i camlp4deps: "tools/compat5b.cmo" i*)
-
-(** Implementation of the TACTIC EXTEND macro. *)
-
-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_var = function
-  | GramNonTerminal(loc',_,_,Some p) -> Some p
-  | GramNonTerminal(loc',_,_,None) -> Some (Id.of_string "_")
-  | _ -> assert false
-
-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 = List.map make_var 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/tacextend.mlp b/grammar/tacextend.mlp
new file mode 100644
index 00000000..683a7e2f
--- /dev/null
+++ b/grammar/tacextend.mlp
@@ -0,0 +1,170 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Implementation of the TACTIC EXTEND macro. *)
+
+open Q_util
+open Argextend
+open GramCompat
+
+let dloc = <:expr< Loc.ghost >>
+
+let plugin_name = <:expr< __coq_plugin_name >>
+
+let mlexpr_of_ident id =
+  (** Workaround for badly-designed generic arguments lacking a closure *)
+  let id = "$" ^ id in
+  <:expr< Names.Id.of_string_soft $str:id$ >>
+
+let rec make_patt = function
+  | [] -> <:patt< [] >>
+  | ExtNonTerminal (_, p) :: l ->
+      <:patt< [ $lid:p$ :: $make_patt l$ ] >>
+  | _::l -> make_patt l
+
+let rec make_let raw e = function
+  | [] -> <:expr< fun $lid:"ist"$ -> $e$ >>
+  | ExtNonTerminal (g, p) :: l ->
+      let t = type_of_user_symbol g in
+      let 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< Tacinterp.Value.cast $make_topwit    loc t$ $lid:p$ >> in
+      <:expr< let $lid:p$ = $v$ in $e$ >>
+  | _::l -> make_let raw e l
+
+let make_clause (pt,_,e) =
+  (make_patt pt,
+   vala None,
+   make_let false e pt)
+
+let make_fun_clauses loc s l =
+  let map c = GramCompat.make_fun loc [make_clause c] in
+  mlexpr_of_list map l
+
+let get_argt e = <:expr< (fun e -> match e with [ Genarg.ExtraArg tag -> tag | _ -> assert False ]) $e$ >>
+
+let rec mlexpr_of_symbol = function
+| Ulist1 s -> <:expr< Extend.Ulist1 $mlexpr_of_symbol s$ >>
+| Ulist1sep (s,sep) -> <:expr< Extend.Ulist1sep $mlexpr_of_symbol s$ $str:sep$ >>
+| Ulist0 s -> <:expr< Extend.Ulist0 $mlexpr_of_symbol s$ >>
+| Ulist0sep (s,sep) -> <:expr< Extend.Ulist0sep $mlexpr_of_symbol s$ $str:sep$ >>
+| Uopt s -> <:expr< Extend.Uopt $mlexpr_of_symbol s$ >>
+| Uentry e ->
+  let arg = get_argt <:expr< $lid:"wit_"^e$ >> in
+  <:expr< Extend.Uentry (Genarg.ArgT.Any $arg$) >>
+| Uentryl (e, l) ->
+  assert (e = "tactic");
+  let arg = get_argt <:expr< Constrarg.wit_tactic >> in
+  <:expr< Extend.Uentryl (Genarg.ArgT.Any $arg$) $mlexpr_of_int l$>>
+
+let make_prod_item = function
+  | ExtTerminal s -> <:expr< Tacentries.TacTerm $str:s$ >>
+  | ExtNonTerminal (g, id) ->
+    <:expr< Tacentries.TacNonTerm $default_loc$ $mlexpr_of_symbol g$ $mlexpr_of_ident id$ >>
+
+let mlexpr_of_clause cl =
+  mlexpr_of_list (fun (a,_,_) -> mlexpr_of_list make_prod_item a) cl
+
+(** Special treatment of constr entries *)
+let is_constr_gram = function
+| ExtTerminal _ -> false
+| ExtNonTerminal (Uentry "constr", _) -> true
+| _ -> false
+
+let make_var = function
+  | ExtNonTerminal (_, p) -> Some p
+  | _ -> assert false
+
+let declare_tactic loc s c cl = match cl with
+| [(ExtTerminal 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 = List.map make_var 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 ml = <:expr< { Tacexpr.mltac_name = $se$; Tacexpr.mltac_index = 0 } >> in
+  let name = mlexpr_of_string name in
+  let tac = match rem with
+  | [] ->
+    (** 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]. *)
+      <:expr< fun _ $lid:"ist"$ -> $tac$ >>
+  | _ ->
+      let f = GramCompat.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$, $ml$, [])) >> 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
+      let () = Tacenv.register_ml_tactic $se$ [|$tac$|] in
+      Mltop.declare_cache_obj obj $plugin_name$ } >>
+    ]
+| _ ->
+  (** 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 gl = mlexpr_of_clause cl in
+  let obj = <:expr< fun () -> Tacentries.add_ml_tactic_notation $se$ $gl$ >> in
+  declare_str_items loc
+    [ <:str_item< do {
+        Tacenv.register_ml_tactic $se$ (Array.of_list $make_fun_clauses loc s cl$);
+        Mltop.declare_cache_obj $obj$ $plugin_name$; } >>
+    ]
+
+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
+	  | ExtNonTerminal _ :: _ ->
+	    (* En attendant la syntaxe de tacticielles *)
+	    failwith "Tactic syntax must start with an identifier"
+	  | _ -> (l,c,e))
+    ] ]
+  ;
+  tacargs:
+    [ [ e = LIDENT; "("; s = LIDENT; ")" ->
+        let e = parse_user_entry e "" in
+        ExtNonTerminal (e, s)
+      | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" ->
+        let e = parse_user_entry e sep in
+        ExtNonTerminal (e, s)
+      | s = STRING ->
+	let () = if s = "" then failwith "Empty terminal." in
+        ExtTerminal s
+    ] ]
+  ;
+  tac_name:
+    [ [ s = LIDENT -> s
+      | s = UIDENT -> s
+    ] ]
+  ;
+  END
diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.mlp
index d789a6c1..04b117fb 100644
--- a/grammar/vernacextend.ml4
+++ b/grammar/vernacextend.mlp
@@ -6,23 +6,17 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "tools/compat5b.cmo" i*)
-
 (** Implementation of the VERNAC EXTEND macro. *)
 
-open Pp
-open Util
 open Q_util
 open Argextend
 open Tacextend
-open Pcoq
-open Egramml
-open Compat
+open GramCompat
 
 type rule = {
   r_head : string option;
   (** The first terminal grammar token *)
-  r_patt : grammar_prod_item list;
+  r_patt : extend_token list;
   (** The remaining tokens of the parsing rule *)
   r_class : MLast.expr option;
   (** An optional classifier for the STM *)
@@ -34,24 +28,25 @@ type rule = {
 
 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
+  | ExtNonTerminal (g, p) :: l ->
+      let t = type_of_user_symbol g in
+      let 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 { r_patt = pt; r_branch = e; } =
   (make_patt pt,
-   vala (Some (make_when (MLast.loc_of_expr e) pt)),
+   vala None,
    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 = function
+  | ExtNonTerminal (_, p) -> p :: accu
+  | _ -> accu
+  in
+  let names = List.fold_left fold [] 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$ } >>
@@ -60,34 +55,34 @@ let make_clause_classifier cg s { r_patt = pt; r_class = c; } =
   match c ,cg with
   | Some c, _ ->
      (make_patt pt,
-      vala (Some (make_when (MLast.loc_of_expr c) pt)),
+      vala None,
       make_let (mk_ignore c pt) pt)
   | None, Some cg ->
      (make_patt pt,
-      vala (Some (make_when (MLast.loc_of_expr cg) pt)),
+      vala None,
       <:expr< fun () -> $cg$ $str:s$ >>)
-  | None, None -> msg_warning
-      (strbrk("Vernac entry \""^s^"\" misses a classifier. "^
+  | None, None -> prerr_endline
+      (("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 "^
+         "of type vernac_classification (see Vernacexpr). You can: ") ^
+       "- " ^ (
+        ("Use '... EXTEND "^s^" CLASSIFIED AS QUERY ...' if the "^
+          "new vernacular command does not alter the system state;"))^ "\n" ^
+       "- " ^ (
+        ("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 "^
+          "parser nor it starts a proof or ends one;"))^ "\n" ^
+       "- " ^ (
+        ("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());
+          "\""^s^"\" as the only argument;")) ^ "\n" ^
+       "- " ^ (
+        "Add a specific classifier in each clause using the syntax:"
+        ^ "\n" ^("'[...] => [ f ] -> [...]'. "))^ "\n" ^
+       ("Specific classifiers have precedence over global "^
+         "classifiers. Only one classifier is called.") ^ "\n");
     (make_patt pt,
-      vala (Some (make_when loc pt)),
+      vala None,
       <:expr< fun () -> (Vernacexpr.VtUnknown, Vernacexpr.VtNow) >>)
 
 let make_fun_clauses loc s l =
@@ -96,19 +91,29 @@ let make_fun_clauses loc s l =
     | None -> false
     | Some () -> true
     in
-    let cl = Compat.make_fun loc [make_clause c] in
+    let cl = GramCompat.make_fun loc [make_clause c] in
     <:expr< ($mlexpr_of_bool depr$, $cl$)>>
   in
   mlexpr_of_list map l
 
 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
+  let cl = List.map (fun x -> GramCompat.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 { r_head = a; r_patt = b; } -> mlexpr_of_list make_prod_item
-       (Option.List.cons (Option.map (fun a -> GramTerminal a) a) b))
+let make_prod_item = function
+  | ExtTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >>
+  | ExtNonTerminal (g, id) ->
+    let nt = type_of_user_symbol g in
+    let base s = <:expr< Pcoq.genarg_grammar ($mk_extraarg loc s$) >> in
+      <:expr< Egramml.GramNonTerminal $default_loc$ $make_rawwit loc nt$
+      $mlexpr_of_prod_entry_key base g$ >>
+
+let mlexpr_of_clause cl =
+  let mkexpr { r_head = a; r_patt = b; } = match a with
+  | None -> mlexpr_of_list make_prod_item b
+  | Some a -> mlexpr_of_list make_prod_item (ExtTerminal a :: b)
+  in
+  mlexpr_of_list mkexpr cl
 
 let declare_command loc s c nt cl =
   let se = mlexpr_of_string s in
@@ -117,14 +122,8 @@ let declare_command loc s c nt cl =
   let classl = make_fun_classifiers loc s c cl in
   declare_str_items loc
     [ <:str_item< do {
-	try do {
-          CList.iteri (fun i (depr, f) -> Vernacinterp.vinterp_add depr ($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 (depr, f) -> Vernacinterp.vinterp_add depr ($se$, i) f) $funcl$;
+        CList.iteri (fun i f -> Vernac_classifier.declare_vernac_classifier ($se$, i) f) $classl$;
 	CList.iteri (fun i r -> Egramml.extend_vernac_command_grammar ($se$, i) $nt$ r) $gl$;
       } >> ]
 
@@ -166,8 +165,7 @@ EXTEND
   rule:
     [ [ "["; s = STRING; l = LIST0 args; "]";
         d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" ->
-      if String.is_empty s then
-        Errors.user_err_loc (!@loc,"",Pp.str"Command name is empty.");
+      let () = if s = "" then failwith "Command name is empty." in
       let b = <:expr< fun () -> $e$ >> in
       { r_head = Some s; r_patt = l; r_class = c; r_branch = b; r_depr = d; }
       | "[" ; "-" ; l = LIST1 args ; "]" ;
@@ -181,13 +179,13 @@ EXTEND
   ;
   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))
+        let e = parse_user_entry e "" in
+        ExtNonTerminal (e, 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))
+        let e = parse_user_entry e sep in
+        ExtNonTerminal (e, s)
       | s = STRING ->
-        GramTerminal s
+        ExtTerminal s
     ] ]
   ;
   END
diff --git a/ide/.merlin b/ide/.merlin
index 3f3d9d27..953b5dce 100644
--- a/ide/.merlin
+++ b/ide/.merlin
@@ -1,4 +1,4 @@
-PKG lablgtk2.sourceview2
+PKG unix laglgtk2 lablgtk2.sourceview2
 
 S utils
 B utils
diff --git a/ide/FAQ b/ide/FAQ
index 07b81824..c8b0a5d3 100644
--- a/ide/FAQ
+++ b/ide/FAQ
@@ -1,7 +1,7 @@
 			CoqIde FAQ
 
 Q0) What is CoqIde?
-R0: A powerfull graphical interface for Coq. See http://coq.inria.fr. for more informations.
+R0: A powerful graphical interface for Coq. See http://coq.inria.fr. for more informations.
 
 Q1) How to enable Emacs keybindings?
 R1: Insert 
diff --git a/ide/coq.lang b/ide/coq.lang
index e25eedbc..484264ec 100644
--- a/ide/coq.lang
+++ b/ide/coq.lang
@@ -95,11 +95,24 @@
       <keyword>Type</keyword>
     </context>
 
-    <context id="coq" class="no-spell-check">
+    <!-- Terms -->
+    <context id="constr">
       <include>
         <context ref="string"/>
         <context ref="coqdoc"/>
         <context ref="comment"/>
+        <context ref="constr-sort"/>
+        <context ref="constr-keyword"/>
+        <context id="dot-nosep">
+          <match>\.\.</match>
+        </context>
+      </include>
+    </context>
+
+    <context id="coq" class="no-spell-check">
+      <include>
+        <context ref="coqdoc"/>
+        <context ref="comment"/>
 
         <context id="declaration">
           <start>\%{decl_head}</start>
@@ -110,14 +123,7 @@
             <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 ref="constr-keyword"/>
-            <context ref="constr-sort"/>
-            <context id="dot-nosep">
-              <match>\.\.</match>
-            </context>
-            <context ref="string"/>
-            <context ref="coqdoc"/>
-            <context ref="comment"/>
+            <context ref="constr"/>
           </include>
         </context>
 
@@ -127,21 +133,19 @@
           <include>
             <context sub-pattern="0" where="start" style-ref="vernac-keyword"/>
             <context sub-pattern="0" where="end" style-ref="vernac-keyword"/>
-            <context ref="command-in-proof"/>
-            <context ref="string"/>
             <context ref="coqdoc"/>
             <context ref="comment"/>
-            <context ref="constr-keyword"/>
-            <context ref="constr-sort"/>
-            <context id="bullet" extend-parent="false">
-              <match>\%{dot_sep}\s*(?'bul'\%{bullet})</match>
+            <context id="bullet" style-ref="vernac-keyword" extend-parent="false">
+              <match>\%{bullet}</match>
+            </context>
+            <context extend-parent="false">
+              <start>\%[</start>
+              <end>\%{dot_sep}</end>
               <include>
-                <context sub-pattern="bul" style-ref="vernac-keyword"/>
+                <context ref="command-in-proof"/>
+                <context ref="constr"/>
               </include>
             </context>
-            <context id="bullet-sol" style-ref="vernac-keyword">
-              <match>^\s*\%{bullet}</match>
-            </context>
           </include>
         </context>
 
@@ -150,11 +154,19 @@
           <end>\%{dot_sep}</end>
           <include>
             <context sub-pattern="0" where="start" style-ref="vernac-keyword"/>
-            <context ref="constr-keyword"/>
-            <context ref="constr-sort"/>
+            <context ref="constr"/>
           </include>
         </context>
 
+        <context ref="command"/>
+      </include>
+    </context>
+
+    <!-- Toplevel commands -->
+    <context id="command" extend-parent="false">
+      <start>\%[</start>
+      <end>\%{dot_sep}</end>
+      <include>
         <context id="command-in-proof" style-ref="vernac-keyword">
           <keyword>About</keyword>
           <keyword>Check</keyword>
@@ -166,7 +178,7 @@
           <keyword>Transparent</keyword>
         </context>
 
-        <context id="command" style-ref="vernac-keyword">
+        <context id="toplevel-command" style-ref="vernac-keyword">
           <keyword>Add</keyword>
           <keyword>Load</keyword>
           <keyword>(Print|Reset)\%{space}+Extraction\%{space}+(Inline|Blacklist)</keyword>
@@ -228,7 +240,10 @@
             <context sub-pattern="qua_list" style-ref="identifier"/>
           </include>
         </context>
+
+        <context ref="constr"/>
       </include>
     </context>
+
   </definitions>
 </language>
diff --git a/ide/coq.ml b/ide/coq.ml
index 98576a98..6d44ca59 100644
--- a/ide/coq.ml
+++ b/ide/coq.ml
@@ -99,9 +99,6 @@ let display_coqtop_answer cmd lines =
      "Command was: "^cmd^"\n"^
      "Answer was: "^(String.concat "\n  " lines))
 
-let check_remaining_opt arg =
-  if arg <> "" && arg.[0] = '-' then fatal_error_popup ("Illegal option: "^arg)
-
 let rec filter_coq_opts args =
   let argstr = String.concat " " (List.map Filename.quote args) in
   let cmd = Filename.quote (coqtop_path ()) ^" -nois -filteropts " ^ argstr in
@@ -125,7 +122,7 @@ and asks_for_coqtop args =
     ~message_type:`QUESTION ~buttons:GWindow.Buttons.yes_no () in
   match pb_mes#run () with
     | `YES ->
-      let () = current.cmd_coqtop  <- None in
+      let () = cmd_coqtop#set None in
       let () = custom_coqtop := None in
       let () = pb_mes#destroy () in
       filter_coq_opts args
@@ -200,8 +197,6 @@ module GlibMainLoop = struct
   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)
@@ -232,7 +227,7 @@ 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;
+  mutable reset_handler : unit task;
   (* called whenever coqtop sends a feedback message *)
   mutable feedback_handler : Feedback.feedback -> unit;
   (* actual coqtop process and its status *)
@@ -295,23 +290,20 @@ let rec check_errors = function
 | `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 
+let handle_intermediate_message handle level content =
+  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
+        | Feedback.Error   -> fun s -> Minilib.log ~level:`ERROR   (xml_to_string s)
+        | Feedback.Info    -> fun s -> Minilib.log ~level:`INFO    (xml_to_string s)
+        | Feedback.Notice  -> fun s -> Minilib.log ~level:`NOTICE  (xml_to_string s)
+        | Feedback.Warning -> fun s -> Minilib.log ~level:`WARNING (xml_to_string s)
+        | Feedback.Debug   -> fun s -> Minilib.log ~level:`DEBUG   (xml_to_string s)
   in
   logger level content
 
 let handle_feedback feedback_processor xml =
-  let feedback = Feedback.to_feedback xml in
+  let feedback = Xmlprotocol.to_feedback xml in
   feedback_processor feedback
 
 let handle_final_answer handle xml =
@@ -336,19 +328,22 @@ let unsafe_handle_input handle feedback_processor state conds ~read_all =
   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 xml = Xml_parser.parse ~do_not_canonicalize:true 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;
+    match Xmlprotocol.is_message xml with
+    | Some (lvl, _loc, msg) ->
+      handle_intermediate_message handle lvl msg;
       loop ()
-    end else begin
-      ignore (handle_final_answer handle xml)
-    end
+    | None ->
+      if Xmlprotocol.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 ->
@@ -362,7 +357,9 @@ let unsafe_handle_input handle feedback_processor state conds ~read_all =
 
 let print_exception = function
   | Xml_parser.Error e -> Xml_parser.error e
-  | Serialize.Marshal_error -> "Protocol violation"
+  | Serialize.Marshal_error(expected,actual) ->
+      "Protocol violation. Expected: " ^ expected ^ " Actual: "
+        ^ Xml_printer.to_string actual
   | e -> Printexc.to_string e
 
 let input_watch handle respawner feedback_processor =
@@ -424,6 +421,7 @@ let mkready coqtop =
   fun () -> coqtop.status <- Ready; Void
 
 let rec respawn_coqtop ?(why=Unexpected) coqtop =
+  if why = Unexpected then warning "Coqtop died badly. Resetting.";
   clear_handle coqtop.handle;
   ignore_error (fun () ->
      coqtop.handle <-
@@ -435,7 +433,7 @@ let rec respawn_coqtop ?(why=Unexpected) coqtop =
      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))
+  ignore (coqtop.reset_handler coqtop.handle (mkready coqtop))
 
 let spawn_coqtop sup_args =
   bind_self_as (fun this -> {
@@ -443,7 +441,7 @@ let spawn_coqtop sup_args =
                (fun () -> respawn_coqtop (this ()))
                (fun msg -> (this ()).feedback_handler msg);
     sup_args = sup_args;
-    reset_handler = (fun _ _ k -> k ());
+    reset_handler = (fun _ k -> k ());
     feedback_handler = (fun _ -> ());
     status = New;
   })
@@ -465,10 +463,6 @@ let close_coqtop coqtop =
 
 let reset_coqtop coqtop = respawn_coqtop ~why:Planned coqtop
 
-let break_coqtop coqtop =
-  try !interrupter (CoqTop.unixpid coqtop.handle.proc)
-  with _ -> Minilib.log "Error while sending Ctrl-C"
-
 let get_arguments coqtop = coqtop.sup_args
 
 let set_arguments coqtop args =
@@ -518,6 +512,17 @@ 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)
 
+let break_coqtop coqtop workers =
+  if coqtop.status = Busy then
+    try !interrupter (CoqTop.unixpid coqtop.handle.proc)
+    with _ -> Minilib.log "Error while sending Ctrl-C"
+  else
+    let rec aux = function
+    | [] -> Void
+    | w :: ws -> stop_worker w coqtop.handle (fun _ -> aux ws)
+    in
+      let Void = aux workers in ()
+
 module PrintOpt =
 struct
   type t = string list
diff --git a/ide/coq.mli b/ide/coq.mli
index d9eda0f3..8a1fa3ed 100644
--- a/ide/coq.mli
+++ b/ide/coq.mli
@@ -60,7 +60,7 @@ val is_computing : coqtop -> bool
 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
+val set_reset_handler : coqtop -> unit task -> unit
 (** Register a handler called when a coqtop dies (badly or on purpose) *)
 
 val set_feedback_handler : coqtop -> (Feedback.feedback -> unit) -> unit
@@ -70,8 +70,8 @@ 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 break_coqtop : coqtop -> string list -> unit
+(** Interrupt the current computation of coqtop or the worker if coqtop it not running. *)
 
 val close_coqtop : coqtop -> unit
 (** Close coqtop. Subsequent requests will be discarded. Hook ignored. *)
diff --git a/ide/coq.png b/ide/coq.png
index cccd5a9a..136bfdd5 100644
--- a/ide/coq.png
+++ b/ide/coq.png
diff --git a/ide/coqOps.ml b/ide/coqOps.ml
index 89f4e513..1563c7ff 100644
--- a/ide/coqOps.ml
+++ b/ide/coqOps.ml
@@ -12,15 +12,19 @@ open Ideutils
 open Interface
 open Feedback
 
-type flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR of string ]
-type mem_flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR ]
+let b2c = byte_offset_to_char_offset
+
+type flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR of Loc.t * string | `WARNING of Loc.t * string ]
+type mem_flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR | `WARNING ]
 let mem_flag_of_flag : flag -> mem_flag = function
   | `ERROR _ -> `ERROR
+  | `WARNING _ -> `WARNING
   | (`INCOMPLETE | `UNSAFE | `PROCESSING) as mem_flag -> mem_flag
 let str_of_flag = function
   | `UNSAFE -> "U"
   | `PROCESSING -> "P"
   | `ERROR _ -> "E"
+  | `WARNING _ -> "W"
   | `INCOMPLETE -> "I"
 
 class type signals =
@@ -44,12 +48,9 @@ module SentenceId : sig
   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
@@ -87,18 +88,15 @@ end = struct
     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)
@@ -130,8 +128,6 @@ end = struct
 end
 open SentenceId
 
-let prefs = Preferences.current
-
 let log msg : unit task =
   Coq.lift (fun () -> Minilib.log msg)
 
@@ -142,7 +138,7 @@ object
   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 handle_reset_initial : unit task
   method raw_coq_query : string -> unit task
   method show_goals : unit task
   method backtrack_last_phrase : unit task
@@ -160,15 +156,71 @@ object
 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 ())
+  else `NAME Preferences.processed_color#get
+
+let validate s =
+  let open Xml_datatype in
+  let rec validate = function
+  | PCData s -> Glib.Utf8.validate s
+  | Element (_, _, children) -> List.for_all validate children
+  in
+  validate (Richpp.repr s)
 
 module Doc = Document
 
+let segment_model (doc : sentence Doc.document) : Wg_Segment.model =
+object (self)
+
+  val mutable cbs = []
+
+  val mutable document_length = 0
+
+  method length = document_length
+
+  method changed ~callback = cbs <- callback :: cbs
+
+  method fold : 'a. ('a -> Wg_Segment.color -> 'a) -> 'a -> 'a = fun f accu ->
+    let fold accu _ _ s =
+      let flags = List.map mem_flag_of_flag s.flags in
+      f accu (flags_to_color flags)
+    in
+    Doc.fold_all doc accu fold
+
+  method private on_changed (i, f) =
+    let data = (i, flags_to_color f) in
+    List.iter (fun f -> f (`SET data)) cbs
+
+  method private on_push s ctx =
+    let after = match ctx with
+    | None -> []
+    | Some (l, _) -> l
+    in
+    List.iter (fun s -> set_index s (s.index + 1)) after;
+    set_index s (document_length - List.length after);
+    ignore ((SentenceId.connect s)#changed self#on_changed);
+    document_length <- document_length + 1;
+    List.iter (fun f -> f `INSERT) cbs
+
+  method private on_pop s ctx =
+    let () = match ctx with
+    | None -> ()
+    | Some (l, _) -> List.iter (fun s -> set_index s (s.index - 1)) l
+    in
+    set_index s (-1);
+    document_length <- document_length - 1;
+    List.iter (fun f -> f `REMOVE) cbs
+
+  initializer
+    let _ = (Doc.connect doc)#pushed self#on_push in
+    let _ = (Doc.connect doc)#popped self#on_pop in
+    ()
+
+end
+
 class coqops
   (_script:Wg_ScriptView.script_view)
   (_pv:Wg_ProofView.proof_view)
@@ -201,20 +253,8 @@ object(self)
     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;
-      ignore ((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 md = segment_model document in
+    segment#set_model md;
     let on_click id =
       let find _ _ s = Int.equal s.index id in
       let sentence = Doc.find document find in
@@ -230,8 +270,6 @@ object(self)
       script#buffer#place_cursor iter;
       ignore (script#scroll_to_iter ~use_align:true ~yalign:0. iter)
     in
-    let _ = (Doc.connect document)#pushed on_push in
-    let _ = (Doc.connect document)#popped on_pop in
     let _ = segment#connect#clicked on_click in
     ()
 
@@ -301,8 +339,11 @@ object(self)
   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;
+      let dest = self#get_start_of_input in
+      if (buffer#get_iter_at_mark `INSERT)#compare dest <= 0 then begin
+        buffer#place_cursor ~where:dest;
+        script#recenter_insert
+      end
     end;
     Coq.bind (Coq.goals ~logger:messages#push ()) (function
     | Fail x -> self#handle_failure_aux ~move_insert x
@@ -322,7 +363,7 @@ object(self)
   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
+      if not (validate s) then
         flash_info "This error is so nasty that I can't even display it."
       else messages#add s;
     in
@@ -331,7 +372,7 @@ object(self)
     let next = function
     | Fail (_, _, err) -> display_error err; Coq.return ()
     | Good msg ->
-      messages#add msg; Coq.return ()
+      messages#add_string msg; Coq.return ()
     in
     Coq.bind (Coq.seq action query) next
 
@@ -362,8 +403,8 @@ object(self)
     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 pre = b2c phrase pre_chars in
+    let post = b2c phrase 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
@@ -406,7 +447,6 @@ object(self)
       | 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;
@@ -424,14 +464,25 @@ object(self)
           log "GlobRef" id;
           self#attach_tooltip sentence loc
             (Printf.sprintf "%s %s %s" filepath ident ty)
-      | ErrorMsg(loc, msg), Some (id,sentence) ->
+      | Message(Error, loc, msg), Some (id,sentence) ->
+          let loc = Option.default Loc.ghost loc in
+          let msg = Richpp.raw_print msg         in
           log "ErrorMsg" id;
           remove_flag sentence `PROCESSING;
-          add_flag sentence (`ERROR msg);
+          add_flag sentence (`ERROR (loc, 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))
+      | Message(Warning, loc, msg), Some (id,sentence) ->
+          let loc = Option.default Loc.ghost loc in
+          let msg = Richpp.raw_print msg         in
+          log "WarningMsg" id;
+          add_flag sentence (`WARNING (loc, msg));
+          self#attach_tooltip sentence loc msg;
+          self#position_warning_tag_at_sentence sentence loc
+      | Message((Info|Notice|Debug as lvl), _, msg), _ ->
+          messages#push lvl msg
       | InProgress n, _ ->
           if n < 0 then processed <- processed + abs n
           else to_process <- to_process + n
@@ -466,13 +517,25 @@ object(self)
     | 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))
+          ~start:(iter#forward_chars (b2c phrase start))
+          ~stop:(iter#forward_chars (b2c 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 position_warning_tag_at_iter iter_start iter_stop phrase loc =
+    if Loc.is_ghost loc then
+        buffer#apply_tag Tags.Script.warning ~start:iter_start ~stop:iter_stop
+    else
+      buffer#apply_tag Tags.Script.warning
+	  ~start:(iter_start#forward_chars (b2c phrase loc.Loc.bp))
+          ~stop:(iter_stop#forward_chars (b2c phrase loc.Loc.ep))
+
+  method private position_warning_tag_at_sentence sentence loc =
+    let start, stop, phrase = self#get_sentence sentence in
+    self#position_warning_tag_at_iter start stop 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
@@ -483,7 +546,7 @@ object(self)
       self#position_error_tag_at_iter start phrase loc;
       buffer#place_cursor ~where:stop;
       messages#clear;
-      messages#push Pp.Error msg;
+      messages#push Feedback.Error msg;
       self#show_goals
     end else
       self#show_goals_aux ~move_insert:true ()
@@ -499,13 +562,19 @@ object(self)
       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 topstack =
+      if Doc.focused document then fst (Doc.context document) else [] in
     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 stop#backward_char#has_tag Tags.Script.processed then begin
+        end else if
+          List.exists (fun (_, s) ->
+            start#equal (buffer#get_iter_at_mark s.start) &&
+            stop#equal (buffer#get_iter_at_mark s.stop)) topstack
+        then begin
           Queue.push (`Skip (start, stop)) queue;
           loop n stop
         end else begin
@@ -559,7 +628,8 @@ object(self)
         if Queue.is_empty queue then conclude topstack else
         match Queue.pop queue, topstack with
         | `Skip(start,stop), [] ->
-            logger Pp.Error "You must close the proof with Qed or Admitted";
+
+            logger Feedback.Error (Richpp.richpp_of_string "You must close the proof with Qed or Admitted");
             self#discard_command_queue queue;
             conclude [] 
         | `Skip(start,stop), (_,s) :: topstack ->
@@ -575,7 +645,7 @@ object(self)
             let handle_answer = function
               | Good (id, (Util.Inl (* NewTip *) (), msg)) ->
                   Doc.assign_tip_id document id;
-                  logger Pp.Notice msg;
+                  logger Feedback.Notice (Richpp.richpp_of_string msg);
                   self#commit_queue_transaction sentence;
                   loop id []
               | Good (id, (Util.Inr (* Unfocus *) tip, msg)) ->
@@ -583,7 +653,7 @@ object(self)
                   let topstack, _ = Doc.context document in
                   self#exit_focus;
                   self#cleanup (Doc.cut_at document tip);
-                  logger Pp.Notice msg;
+                  logger Feedback.Notice (Richpp.richpp_of_string msg);
                   self#mark_as_needed sentence;
                   if Queue.is_empty queue then loop tip []
                   else loop tip (List.rev topstack)
@@ -602,7 +672,7 @@ object(self)
    let next = function
      | Good _ ->
          messages#clear;
-         messages#push Pp.Info "All proof terms checked by the kernel";
+         messages#push Feedback.Info (Richpp.richpp_of_string "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
@@ -618,7 +688,15 @@ object(self)
   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
+      | `ERROR (loc, msg) ->
+         let iter =
+           if Loc.is_ghost loc then
+             buffer#get_iter_at_mark s.start
+           else
+             let (iter, _, phrase) = self#get_sentence s in
+             let (start, _) = Loc.unloc loc in
+             iter#forward_chars (b2c phrase start) in
+         iter#line + 1, msg
       | _ -> assert false in
     List.rev
       (Doc.fold_all document [] (fun acc _ _ s ->
@@ -630,7 +708,7 @@ object(self)
 
   method private process_until_iter iter =
     let until _ start stop =
-      if prefs.Preferences.stop_before then stop#compare iter > 0
+      if Preferences.stop_before#get then stop#compare iter > 0
       else start#compare iter >= 0
     in
     self#process_until until false
@@ -696,8 +774,8 @@ object(self)
           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 loc <> None then messages#push Feedback.Error (Richpp.richpp_of_string "Fixme LOC"); *)
+          messages#push Feedback.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))
@@ -714,8 +792,7 @@ object(self)
   method private handle_failure_aux
     ?(move_insert=false) (safe_id, (loc : (int * int) option), msg)
   =
-    messages#clear;
-    messages#push Pp.Error msg;
+    messages#push Feedback.Error msg;
     ignore(self#process_feedback ());
     if Stateid.equal safe_id Stateid.dummy then Coq.lift (fun () -> ())
     else
@@ -772,7 +849,7 @@ object(self)
       self#show_goals
     in
     let display_error (loc, s) =
-      if not (Glib.Utf8.validate s) then
+      if not (validate s) then
         flash_info "This error is so nasty that I can't even display it."
       else messages#add s
     in
@@ -782,10 +859,10 @@ object(self)
       let next = function
       | Fail (_, l, str) -> (* FIXME: check *)
         display_error (l, str);
-        messages#add ("Unsuccessfully tried: "^phrase);
+        messages#add (Richpp.richpp_of_string ("Unsuccessfully tried: "^phrase));
         more
       | Good msg ->
-        messages#add msg;
+        messages#add_string msg;
         stop Tags.Script.processed
       in
       Coq.bind (Coq.seq action query) next
@@ -797,10 +874,8 @@ object(self)
     in
     loop l
 
-  method handle_reset_initial why =
+  method handle_reset_initial =
     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
@@ -829,7 +904,10 @@ object(self)
   method initialize =
     let get_initial_state =
       let next = function
-      | Fail _ -> messages#set ("Couln't initialize Coq"); Coq.return ()
+      | Fail (_, _, message) ->
+        let message = "Couldn't initialize coqtop\n\n" ^ (Richpp.raw_print message) in
+        let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok ~message_type:`ERROR ~message () in
+        ignore (popup#run ()); exit 1
       | Good id -> initial_state <- id; Coq.return () in
       Coq.bind (Coq.init (get_filename ())) next in
     Coq.seq get_initial_state Coq.PrintOpt.enforce
diff --git a/ide/coqOps.mli b/ide/coqOps.mli
index 4a37a1fa..332c18f2 100644
--- a/ide/coqOps.mli
+++ b/ide/coqOps.mli
@@ -15,7 +15,7 @@ object
   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 handle_reset_initial : unit task
   method raw_coq_query : string -> unit task
   method show_goals : unit task
   method backtrack_last_phrase : unit task
diff --git a/ide/coqide.ml b/ide/coqide.ml
index 608cf82f..450bfcdf 100644
--- a/ide/coqide.ml
+++ b/ide/coqide.ml
@@ -44,8 +44,6 @@ open Session
 
 (** {2 Some static elements } *)
 
-let prefs = Preferences.current
-
 (** 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 []
@@ -87,9 +85,9 @@ 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
+      !custom_project_files project_file_name#get
     in
-    match prefs.read_project with
+    match read_project#get with
       |Ignore_args -> "", !sup_args
       |Append_args ->
          let fname, args = get_args the_file in fname, args @ !sup_args
@@ -164,7 +162,6 @@ let load_file ?(maycreate=false) f =
       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))
@@ -250,7 +247,6 @@ module File = struct
 let newfile _ =
   let session = create_session None in
   let index = notebook#append_term session in
-  !refresh_editor_hook ();
   notebook#goto_page index
 
 let load _ =
@@ -319,13 +315,13 @@ let export kind sn =
           | _ -> assert false
       in
       let cmd =
-        local_cd f ^ prefs.cmd_coqdoc ^ " --" ^ kind ^ " -o " ^
+        local_cd f ^ cmd_coqdoc#get ^ " --" ^ kind ^ " -o " ^
         (Filename.quote output) ^ " " ^ (Filename.quote basef) ^ " 2>&1"
       in
-      sn.messages#set ("Running: "^cmd);
+      sn.messages#set (Richpp.richpp_of_string ("Running: "^cmd));
       let finally st = flash_info (cmd ^ pr_exit_status st)
       in
-      run_command sn.messages#add finally cmd
+      run_command (fun msg -> sn.messages#add_string msg) finally cmd
 
 let export kind = cb_on_current_term (export kind)
 
@@ -334,8 +330,8 @@ let print sn =
     |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
+        local_cd f_name ^ cmd_coqdoc#get ^ " -ps " ^
+        Filename.quote (Filename.basename f_name) ^ " | " ^ cmd_print#get
       in
       let w = GWindow.window ~title:"Print" ~modal:true
         ~position:`CENTER ~wm_class:"CoqIDE" ~wm_name: "CoqIDE" ()
@@ -378,17 +374,17 @@ end
 
 let reset_revert_timer () =
   FileOps.revert_timer.kill ();
-  if prefs.global_auto_revert then
+  if global_auto_revert#get then
     FileOps.revert_timer.run
-      ~ms:prefs.global_auto_revert_delay
+      ~ms:global_auto_revert_delay#get
       ~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
+  if auto_save#get then
+    FileOps.autosave_timer.run ~ms:auto_save_delay#get ~callback:autosave_all
 
 (** Export of functions used in [coqide_main] : *)
 
@@ -408,8 +404,8 @@ 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)
+      let cmd = local_cd f ^ cmd_coqmakefile#get in
+      let finally st = flash_info (cmd_coqmakefile#get ^ pr_exit_status st)
       in
       run_command ignore finally cmd
 
@@ -421,7 +417,7 @@ let editor sn =
     |Some f ->
       File.save ();
       let f = Filename.quote f in
-      let cmd = Util.subst_command_placeholder prefs.cmd_editor f in
+      let cmd = Util.subst_command_placeholder cmd_editor#get f in
       run_command ignore (fun _ -> sn.fileops#revert) cmd
 
 let editor = cb_on_current_term editor
@@ -431,13 +427,13 @@ let compile sn =
   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))
+      let cmd = cmd_coqc#get ^ " -I " ^ (Filename.quote (Filename.dirname f))
 	^ " " ^ (Filename.quote f) ^ " 2>&1"
       in
       let buf = Buffer.create 1024 in
-      sn.messages#set ("Running: "^cmd);
+      sn.messages#set (Richpp.richpp_of_string ("Running: "^cmd));
       let display s =
-        sn.messages#add s;
+        sn.messages#add_string s;
         Buffer.add_string buf s
       in
       let finally st =
@@ -445,8 +441,8 @@ let compile sn =
           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);
+          sn.messages#set (Richpp.richpp_of_string "Compilation output:\n");
+          sn.messages#add (Richpp.richpp_of_string (Buffer.contents buf));
         end
       in
       run_command display finally cmd
@@ -467,17 +463,17 @@ let make sn =
     |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";
+      let cmd = local_cd f ^ cmd_make#get ^ " 2>&1" in
+      sn.messages#set (Richpp.richpp_of_string "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;
+        sn.messages#add_string s;
         Buffer.add_string last_make_buf s
       in
-      let finally st = flash_info (current.cmd_make ^ pr_exit_status st)
+      let finally st = flash_info (cmd_make#get ^ pr_exit_status st)
       in
       run_command display finally cmd
 
@@ -512,11 +508,11 @@ let next_error sn =
     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.messages#set (Richpp.richpp_of_string error_msg);
     sn.script#misc#grab_focus ()
   with Not_found ->
     last_make_index := 0;
-    sn.messages#set "No more errors.\n"
+    sn.messages#set (Richpp.richpp_of_string "No more errors.\n")
 
 let next_error = cb_on_current_term next_error
 
@@ -537,7 +533,7 @@ let update_status sn =
       | None -> ""
       | Some n -> ", proving " ^ n
     in
-    display ("Ready"^ (if current.nanoPG then ", [μPG]" else "") ^ path ^ name);
+    display ("Ready"^ (if nanoPG#get then ", [μPG]" else "") ^ path ^ name);
     Coq.return ()
   in
   Coq.bind (Coq.status ~logger:sn.messages#push false) next
@@ -574,7 +570,7 @@ module Nav = struct
   let restart _ = on_current_term restart
   let interrupt sn =
     Minilib.log "User break received";
-    Coq.break_coqtop sn.coqtop
+    Coq.break_coqtop sn.coqtop CString.(Set.elements (Map.domain sn.jobpage#data))
   let interrupt = cb_on_current_term interrupt
   let join_document _ = send_to_coq (fun sn -> sn.coqops#join_document)
 end
@@ -681,12 +677,18 @@ let searchabout sn =
 
 let searchabout () = on_current_term searchabout
 
+let doquery query sn =
+  sn.messages#clear;
+  Coq.try_grab sn.coqtop (sn.coqops#raw_coq_query query) ignore
+
 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
+  Option.iter (fun query -> doquery (query ^ ".") sn)
+    begin try
+      let i = CString.string_index_from command 0 "..." in
+      let word = get_current_word sn in
+      if word = "" then None
+      else Some (CString.sub command 0 i ^ " " ^ word)
+    with Not_found -> Some command end
 
 let otherquery command = cb_on_current_term (otherquery command)
 
@@ -722,7 +724,7 @@ let initial_about () =
     else ""
   in
   let msg = initial_string ^ version_info ^ log_file_message () in
-  on_current_term (fun term -> term.messages#add msg)
+  on_current_term (fun term -> term.messages#add_string msg)
 
 let coq_icon () =
   (* May raise Nof_found *)
@@ -787,7 +789,7 @@ let coqtop_arguments sn =
         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
+        sn.messages#push Feedback.Error (Richpp.richpp_of_string msg)
     else dialog#destroy ()
   in
   let _ = entry#connect#activate ok_cb in
@@ -809,69 +811,19 @@ let zoom_fit sn =
   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
+  let fsize = Pango.Font.get_size (Pango.Font.from_string text_font#get) 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
+  Pango.Font.set_size (Pango.Font.from_string text_font#get)
     (fsize * space / tlen / Pango.scale * Pango.scale);
-  save_pref ();
-  !refresh_editor_hook ()
+  save_pref ()
 
 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 fd = prefs.text_font in
-  let clr = Tags.color_of_string prefs.background_color
-  in
-  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
-    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 *)
-    Tags.set_processing_color (Tags.color_of_string current.processing_color);
-    Tags.set_processed_color (Tags.color_of_string current.processed_color);
-    Tags.set_error_color (Tags.color_of_string current.error_color);
-    Tags.set_error_fg_color (Tags.color_of_string current.error_fg_color);
-    sn.script#misc#modify_base [`NORMAL, `COLOR clr];
-    sn.proof#misc#modify_base [`NORMAL, `COLOR clr];
-    sn.messages#refresh_color ();
-    sn.command#refresh_color ();
-    sn.errpage#refresh_color ();
-    sn.jobpage#refresh_color ();
-
-  in
-  List.iter iter_session notebook#pages
-
 let refresh_notebook_pos () =
-  let pos = match prefs.vertical_tabs, prefs.opposite_tabs with
+  let pos = match vertical_tabs#get, opposite_tabs#get with
     | false, false -> `TOP
     | false, true  -> `BOTTOM
     | true , false -> `LEFT
@@ -906,19 +858,19 @@ 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
+    let accel = Option.map ((^) modifier_for_display#get) k in
     toggle_item name ~label ?accel ~active:d.Opt.init
       ~callback:(printopts_callback d.Opt.opts)
       menu_name
   in
   List.iter f l
 
+let no_under = Util.String.map (fun x -> if x = '_' then '-' else x)
+
 (** 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 mk_item text =
     let text' =
       let last = String.length text - 1 in
@@ -948,7 +900,7 @@ let alpha_items menu_name item_name l =
     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 modifier = modifier_for_templates#get in
   let idx = String.index text ' ' in
   let name = String.sub text 0 idx in
   let label = "_"^name^" __" in
@@ -965,6 +917,16 @@ let template_item (text, offset, len, key) =
   in
   item name ~label ~callback:(cb_on_current_term callback) ~accel:(modifier^key)
 
+(** Create menu items for pairs (query, shortcut key). *)
+let user_queries_items menu_name item_name l =
+  let mk_item (query, key) =
+    let callback = Query.query query in
+    let accel = if not (CString.is_empty key) then
+      Some (modifier_for_queries#get^key) else None in
+    item (item_name^" "^(no_under query)) ~label:query ?accel ~callback menu_name
+  in
+  List.iter mk_item l
+
 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
@@ -975,8 +937,7 @@ let emit_to_focus window sgn =
 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
+    ~width:window_width#get ~height:window_height#get
     ~title:"CoqIde" ()
   in
   let () =
@@ -1074,77 +1035,60 @@ let build_ui () =
       ~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 ());
+          let ft = Pango.Font.from_string text_font#get in
+          Pango.Font.set_size ft (Pango.Font.get_size ft + Pango.scale);
+          text_font#set (Pango.Font.to_string ft);
+          save_pref ());
     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 ());
+          let ft = Pango.Font.from_string text_font#get in
+          Pango.Font.set_size ft (Pango.Font.get_size ft - Pango.scale);
+          text_font#set (Pango.Font.to_string ft);
+          save_pref ());
     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 ());
+      ~active:(show_toolbar#get)
+      ~callback:(fun _ -> show_toolbar#set (not show_toolbar#get));
     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:(prefs.modifier_for_navigation^"h");*)
-    item "Previous" ~label:"_Previous" ~stock:`GO_BACK
-      ~callback:Nav.previous_occ
-      ~tooltip:"Previous occurrence"
-      ~accel:(prefs.modifier_for_navigation^"less");
-    item "Next" ~label:"_Next" ~stock:`GO_FORWARD ~callback:Nav.next_occ
-      ~tooltip:"Next occurrence"
-      ~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 navitem (text, label, stock, callback, tooltip, accel) =
+    let accel = modifier_for_navigation#get ^ accel in
+    item text ~label ~stock ~callback ~tooltip ~accel
+  in
+  menu navigation_menu begin
+  [
+    (fun e -> item "Navigation" ~label:"_Navigation" e);
+  ] @ List.map navitem [
+    ("Forward", "_Forward", `GO_DOWN, Nav.forward_one, "Forward one command", "Down");
+    ("Backward", "_Backward", `GO_UP, Nav.backward_one, "Backward one command", "Up");
+    ("Go to", "_Go to", `JUMP_TO, Nav.goto, "Go to cursor", "Right");
+    ("Start", "_Start", `GOTO_TOP, Nav.restart, "Restart coq", "Home");
+    ("End", "_End", `GOTO_BOTTOM, Nav.goto_end, "Go to end", "End");
+    ("Interrupt", "_Interrupt", `STOP, Nav.interrupt, "Interrupt computations", "Break");
+    (* wait for this available in GtkSourceView !
+    ("Hide", "_Hide", `MISSING_IMAGE,
+        ~callback:(fun _ -> let sess = notebook#current_term in
+          toggle_proof_visibility sess.buffer sess.analyzed_view#get_insert), "Hide proof", "h"); *)
+    ("Previous", "_Previous", `GO_BACK, Nav.previous_occ, "Previous occurrence", "less");
+    ("Next", "_Next", `GO_FORWARD, Nav.next_occ, "Next occurrence", "greater");
+    ("Force", "_Force", `EXECUTE, Nav.join_document, "Fully check the document", "f");
+  ] end;
 
   let tacitem s sc =
     item s ~label:("_"^s)
-      ~accel:(prefs.modifier_for_tactics^sc)
+      ~accel:(modifier_for_tactics#get^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);
+      ~tooltip:"Proof Wizard" ~accel:(modifier_for_tactics#get^"dollar")
+      ~callback:(tactic_wizard_callback automatic_tactics#get);
     tacitem "auto" "a";
     tacitem "auto with *" "asterisk";
     tacitem "eauto" "e";
@@ -1166,21 +1110,27 @@ let build_ui () =
     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^"M")
+    item "match" ~label:"match ..." ~accel:(modifier_for_templates#get^"M")
       ~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
+  let qitem s sc ?(dots = true) =
+    let query = if dots then s ^ "..." else s in
+    item s ~label:("_"^s)
+      ~accel:(modifier_for_queries#get^sc)
+      ~callback:(Query.query query)
+  in
   menu queries_menu [
     item "Queries" ~label:"_Queries";
-    qitem "Search" (Some "<Ctrl><Shift>K");
-    qitem "Check" (Some "<Ctrl><Shift>C");
-    qitem "Print" (Some "<Ctrl><Shift>P");
-    qitem "About" (Some "<Ctrl><Shift>A");
-    qitem "Locate" (Some "<Ctrl><Shift>L");
-    qitem "Print Assumptions" (Some "<Ctrl><Shift>N");
+    qitem "Search" "K" ~dots:false;
+    qitem "Check" "C";
+    qitem "Print" "P";
+    qitem "About" "A";
+    qitem "Locate" "L";
+    qitem "Print Assumptions" "N";
   ];
+  user_queries_items queries_menu "User-Query" user_queries#get;
 
   menu tools_menu [
     item "Tools" ~label:"_Tools";
@@ -1211,17 +1161,17 @@ let build_ui () =
     item "Help" ~label:"_Help";
     item "Browse Coq Manual" ~label:"Browse Coq _Manual"
       ~callback:(fun _ ->
-        browse notebook#current_term.messages#add (doc_url ()));
+        browse notebook#current_term.messages#add_string (doc_url ()));
     item "Browse Coq Library" ~label:"Browse Coq _Library"
       ~callback:(fun _ ->
-        browse notebook#current_term.messages#add prefs.library_url);
+        browse notebook#current_term.messages#add_string library_url#get);
     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)));
+        browse_keyword sn.messages#add_string (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 ())));
+         sn.messages#add_string (NanoPG.get_documentation ())));
     item "About Coq" ~label:"_About" ~stock:`ABOUT
       ~callback:MiscMenu.about
   ];
@@ -1259,7 +1209,7 @@ let build_ui () =
 
   (* Reset on tab switch *)
   let _ = notebook#connect#switch_page ~callback:(fun _ ->
-    if prefs.reset_on_tab_switch then Nav.restart ())
+    if reset_on_tab_switch#get then Nav.restart ())
   in
 
   (* Vertical Separator between Scripts and Goals *)
@@ -1267,7 +1217,7 @@ let build_ui () =
   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
+  let () = push_info ("Ready"^ if nanoPG#get then ", [μPG]" else "")  in
 
   (* Location display *)
   let l = GMisc.label
@@ -1310,43 +1260,33 @@ let build_ui () =
   let _ = Glib.Timeout.add ~ms:300 ~callback in
 
   (* Initializing hooks *)
-  let refresh_toolbar () =
-    if prefs.show_toolbar
-    then toolbar#misc#show ()
-    else toolbar#misc#hide ()
-  in
-  let refresh_style () =
-    let style =  style_manager#style_scheme prefs.source_style in
+  let refresh_style style =
+    let style = style_manager#style_scheme style in
     let iter_session v = v.script#source_buffer#set_style_scheme style in
     List.iter iter_session notebook#pages
   in
-  let refresh_language () =
-    let lang =  lang_manager#language prefs.source_language in
+  let refresh_language lang =
+    let lang = lang_manager#language lang in
     let iter_session v = v.script#source_buffer#set_language lang in
     List.iter iter_session notebook#pages
   in
-  let resize_window () =
-    w#resize ~width:prefs.window_width ~height:prefs.window_height
+  let refresh_toolbar b =
+    if b then toolbar#misc#show () else toolbar#misc#hide ()
   in
-  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;
+  stick show_toolbar toolbar refresh_toolbar;
+  let _ = source_style#connect#changed refresh_style in
+  let _ = source_language#connect#changed refresh_language in
 
   (* Color configuration *)
   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 =
@@ -1356,7 +1296,7 @@ let make_file_buffer 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 ();
diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml
index edfe28b2..2ae18593 100644
--- a/ide/coqide_ui.ml
+++ b/ide/coqide_ui.ml
@@ -18,6 +18,15 @@ let list_items menu li =
   let () = List.iter (fun b -> Buffer.add_buffer res_buf (tactic_item b)) li in
   res_buf
 
+let list_queries menu li =
+  let res_buf = Buffer.create 500 in
+  let query_item (q, _) =
+    let s = "<menuitem action='"^menu^" "^(no_under q)^"' />\n" in
+    Buffer.add_string res_buf s
+  in
+  let () = List.iter query_item li in
+  res_buf
+
 let init () =
   let theui = Printf.sprintf "<ui>
 <menubar name='CoqIde MenuBar'>
@@ -119,6 +128,8 @@ let init () =
     <menuitem action='About' />
     <menuitem action='Locate' />
     <menuitem action='Print Assumptions' />
+    <separator />
+    %s
   </menu>
   <menu name='Tools' action='Tools'>
     <menuitem action='Comment' />
@@ -162,5 +173,6 @@ let init () =
     (if Coq_config.gtk_platform <> `QUARTZ then "<menuitem action='Quit' />" else "")
     (Buffer.contents (list_items "Tactic" Coq_commands.tactics))
     (Buffer.contents (list_items "Template" Coq_commands.commands))
+    (Buffer.contents (list_queries "User-Query" Preferences.user_queries#get))
  in
   ignore (ui_m#add_ui_from_string theui);
diff --git a/ide/coqidetop.mllib b/ide/coqidetop.mllib
index 92301dc3..ed1fa465 100644
--- a/ide/coqidetop.mllib
+++ b/ide/coqidetop.mllib
@@ -1,2 +1,9 @@
+Xml_lexer
+Xml_parser
+Xml_printer
+Serialize
+Richprinter
 Xmlprotocol
+Texmacspp
+Document
 Ide_slave
diff --git a/ide/document.ml b/ide/document.ml
index 9823e757..62457fe5 100644
--- a/ide/document.ml
+++ b/ide/document.ml
@@ -16,8 +16,8 @@ type id = Stateid.t
 
 class type ['a] signals =
   object
-    method popped : callback:('a -> unit) -> unit
-    method pushed : callback:('a -> unit) -> unit
+    method popped : callback:('a -> ('a list * 'a list) option -> unit) -> unit
+    method pushed : callback:('a -> ('a list * 'a list) option -> unit) -> unit
   end
 
 class ['a] signal () =
@@ -32,14 +32,14 @@ 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;
+  pushed_sig : ('a * ('a list * 'a list) option) signal;
+  popped_sig : ('a * ('a list * 'a list) option) signal;
 }
 
-let connect d =
+let connect d : 'a signals =
   object
-    method pushed ~callback = d.pushed_sig#connect callback
-    method popped ~callback = d.popped_sig#connect callback
+    method pushed ~callback = d.pushed_sig#connect (fun (x, ctx) -> callback x ctx)
+    method popped ~callback = d.popped_sig#connect (fun (x, ctx) -> callback x ctx)
   end
 
 let create () = {
@@ -49,6 +49,12 @@ let create () = {
   popped_sig = new signal ();
 }
 
+let repr_context s = match s.context with
+| None -> None
+| Some (cl, cr) ->
+  let map s = s.data in
+  Some (List.map map cl, List.map map cr)
+
 (* Invariant, only the tip is a allowed to have state_id = None *)
 let invariant l = l = [] || (List.hd l).state_id <> None
 
@@ -64,12 +70,13 @@ let tip_data = function
 let push d x =
   assert(invariant d.stack);
   d.stack <- { data = x; state_id = None } :: d.stack;
-  d.pushed_sig#call x
+  d.pushed_sig#call (x, repr_context d)
 
 let pop = function
   | { stack = [] } -> raise Empty
-  | { stack = { data }::xs } as s -> s.stack <- xs; s.popped_sig#call data; data
-  
+  | { stack = { data }::xs } as s ->
+    s.stack <- xs; s.popped_sig#call (data, repr_context s); data
+
 let focus d ~cond_top:c_start ~cond_bot:c_stop =
   assert(invariant d.stack);
   if d.context <> None then invalid_arg "focus";
@@ -124,12 +131,6 @@ let context d =
   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 =
@@ -154,7 +155,7 @@ let cut_at d id =
     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;
+  for _i = 1 to n do ignore(pop d) done;
   List.rev zone
 
 let find_id d f =
diff --git a/ide/document.mli b/ide/document.mli
index 0d803ff0..fb96cb6d 100644
--- a/ide/document.mli
+++ b/ide/document.mli
@@ -108,8 +108,8 @@ val print :
 
 class type ['a] signals =
   object
-    method popped : callback:('a -> unit) -> unit
-    method pushed : callback:('a -> unit) -> unit
+    method popped : callback:('a -> ('a list * 'a list) option -> unit) -> unit
+    method pushed : callback:('a -> ('a list * 'a list) option -> unit) -> unit
   end
 
 val connect : 'a document -> 'a signals
diff --git a/ide/fileOps.ml b/ide/fileOps.ml
index 835ea014..7be1bdb9 100644
--- a/ide/fileOps.ml
+++ b/ide/fileOps.ml
@@ -8,8 +8,6 @@
 
 open Ideutils
 
-let prefs = Preferences.current
-
 let revert_timer = mktimer ()
 let autosave_timer = mktimer ()
 
@@ -87,7 +85,7 @@ object(self)
                 flash_info "Could not overwrite file"
             | _ ->
               Minilib.log "Auto revert set to false";
-              prefs.Preferences.global_auto_revert <- false;
+              Preferences.global_auto_revert#set false;
               revert_timer.kill ()
 
   method save f =
@@ -120,9 +118,9 @@ object(self)
       | None -> None
       | Some f ->
         let dir = Filename.dirname f in
-        let base = (fst prefs.Preferences.auto_save_name) ^
+        let base = (fst Preferences.auto_save_name#get) ^
           (Filename.basename f) ^
-          (snd prefs.Preferences.auto_save_name)
+          (snd Preferences.auto_save_name#get)
         in Some (Filename.concat dir base)
 
   method private need_auto_save =
diff --git a/ide/ide.mllib b/ide/ide.mllib
index e082bd18..b2f32fcf 100644
--- a/ide/ide.mllib
+++ b/ide/ide.mllib
@@ -9,18 +9,23 @@ Configwin
 Editable_cells
 Config_parser
 Tags
-Wg_Segment
 Wg_Notebook
 Config_lexer
 Utf8_convert
 Preferences
 Project_file
-Ideutils
+Serialize
+Richprinter
+Xml_lexer
+Xml_parser
+Xml_printer
 Xmlprotocol
+Ideutils
 Coq
 Coq_lex
 Sentence
 Gtk_parsing
+Wg_Segment
 Wg_ProofView
 Wg_MessageView
 Wg_Detachable
diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml
index bd98fe16..5b07d3ec 100644
--- a/ide/ide_slave.ml
+++ b/ide/ide_slave.ml
@@ -1,4 +1,5 @@
 (************************************************************************)
+
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
@@ -7,7 +8,7 @@
 (************************************************************************)
 
 open Vernacexpr
-open Errors
+open CErrors
 open Util
 open Pp
 open Printer
@@ -47,6 +48,7 @@ let init_stdout, read_stdout =
 
 let pr_with_pid s = Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s
 
+let pr_error s = pr_with_pid s
 let pr_debug s =
   if !Flags.debug then pr_with_pid s
 let pr_debug_call q =
@@ -94,15 +96,15 @@ let is_undo cmd = match cmd with
 (** 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
+  let user_error s = CErrors.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");
+    Feedback.msg_warning (strbrk"This will not work. Use CoqIDE view menu instead");
   if Vernac.is_navigation_vernac ast || is_undo ast then
-    msg_warning (strbrk "Rather use CoqIDE navigation instead");
+    Feedback.msg_warning (strbrk "Rather use CoqIDE navigation instead");
   if is_query ast then
-    msg_warning (strbrk "Query commands should not be inserted in scripts")
+    Feedback.msg_warning (strbrk "Query commands should not be inserted in scripts")
 
 (** Interpretation (cf. [Ide_intf.interp]) *)
 
@@ -130,7 +132,8 @@ let annotate phrase =
 
 (** Goal display *)
 
-let hyp_next_tac sigma env (id,_,ast) =
+let hyp_next_tac sigma env decl =
+  let (id,_,ast) = Context.Named.Declaration.to_tuple decl in
   let id_s = Names.Id.to_string id in
   let type_s = string_of_ppcmds (pr_ltype_env env sigma ast) in
   [
@@ -184,14 +187,19 @@ let process_goal sigma g =
   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
+    Richpp.richpp_of_pp (pr_goal_concl_style_env env sigma norm_constr)
+  in
   let process_hyp d (env,l) =
-    let d = Context.map_named_list_declaration (Reductionops.nf_evar sigma) d in
-    let d' = List.map (fun x -> (x, pi2 d, pi3 d)) (pi1 d) in
+    let d = Context.NamedList.Declaration.map_constr (Reductionops.nf_evar sigma) d in
+    let d' = List.map (fun name -> let open Context.Named.Declaration in
+                                   match pi2 d with
+                                   | None -> LocalAssum (name, pi3 d)
+                                   | Some value -> LocalDef (name, value, pi3 d))
+                      (pi1 d) in
       (List.fold_right Environ.push_named d' env,
-       (string_of_ppcmds (pr_var_list_decl env sigma d)) :: l) in
+       (Richpp.richpp_of_pp (pr_var_list_decl env sigma d)) :: l) in
   let (_env, hyps) =
-    Context.fold_named_list_context process_hyp
+    Context.NamedList.fold process_hyp
       (Termops.compact_named_context (Environ.named_context env)) ~init:(min_env,[]) in
   { Interface.goal_hyp = List.rev hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; }
 
@@ -206,7 +214,7 @@ let export_pre_goals pgs =
 let goals () =
   Stm.finish ();
   let s = read_stdout () in
-  if not (String.is_empty s) then msg_info (str s);
+  if not (String.is_empty s) then Feedback.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))
@@ -216,7 +224,7 @@ let evars () =
   try
     Stm.finish ();
     let s = read_stdout () in
-    if not (String.is_empty s) then msg_info (str s);
+    if not (String.is_empty s) then Feedback.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
@@ -249,7 +257,7 @@ let status force =
   Stm.finish ();
   if force then Stm.join ();
   let s = read_stdout () in
-  if not (String.is_empty s) then msg_info (str s);
+  if not (String.is_empty s) then Feedback.msg_info (str s);
   let path =
     let l = Names.DirPath.repr (Lib.cwd ()) in
     List.rev_map Names.Id.to_string l
@@ -275,11 +283,33 @@ let export_coq_object t = {
   Interface.coq_object_object = t.Search.coq_object_object
 }
 
+let pattern_of_string ?env s =
+  let env =
+    match env with
+    | None -> Global.env ()
+    | Some e -> e
+  in
+  let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in
+  let (_, pat) = Constrintern.intern_constr_pattern env constr in
+  pat
+
+let dirpath_of_string_list s =
+  let path = String.concat "." s 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 ->
+      CErrors.errorlabstrm "Search.interface_search"
+        (str "Module " ++ str path ++ str " not found.")
+  in
+  id
+
 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.Name_Pattern s    -> Search.Name_Pattern (Str.regexp s)
+  | Interface.Type_Pattern s    -> Search.Type_Pattern (pattern_of_string s)
+  | Interface.SubType_Pattern s -> Search.SubType_Pattern (pattern_of_string s)
+  | Interface.In_Module ms      -> Search.In_Module (dirpath_of_string_list ms)
   | Interface.Include_Blacklist -> Search.Include_Blacklist
 
 let search flags =
@@ -333,10 +363,14 @@ let handle_exn (e, info) =
   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 () = read_stdout ()^"\n"^string_of_ppcmds (Errors.print ~info e) in
+  let mk_msg () =
+    let msg = read_stdout () in
+    let msg = str msg ++ fnl () ++ CErrors.print ~info e in
+    Richpp.richpp_of_pp msg
+  in
   match e with
-  | Errors.Drop -> dummy, None, "Drop is not allowed by coqide!"
-  | Errors.Quit -> dummy, None, "Quit is not allowed by coqide!"
+  | CErrors.Drop -> dummy, None, Richpp.richpp_of_string "Drop is not allowed by coqide!"
+  | CErrors.Quit -> dummy, None, Richpp.richpp_of_string "Quit is not allowed by coqide!"
   | e ->
       match Stateid.get info with
       | Some (valid, _) -> valid, loc_of info, mk_msg ()
@@ -351,8 +385,6 @@ let init =
      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, _ =
@@ -361,6 +393,7 @@ let init =
                0 (Printf.sprintf "Add LoadPath \"%s\". " dir)
            else Stm.get_current_state (), `NewTip in
          Stm.set_compilation_hints file;
+         Stm.finish ();
          initial_id
    end
 
@@ -382,6 +415,15 @@ let interp ((_raw, verbose), s) =
 
 let quit = ref false
 
+(** Serializes the output of Stm.get_ast  *)
+let print_ast id =
+  match Stm.get_ast id with
+  | Some (expr, loc) -> begin
+      try  Texmacspp.tmpp expr loc
+      with e -> Xml_datatype.PCData ("ERROR " ^ Printexc.to_string e)
+    end
+  | None     -> Xml_datatype.PCData "ERROR"
+
 (** Grouping all call handlers together + error handling *)
 
 let eval_call xml_oc log c =
@@ -412,7 +454,7 @@ let eval_call xml_oc log c =
     Interface.interp = interruptible interp;
     Interface.handle_exn = handle_exn;
     Interface.stop_worker = Stm.stop_worker;
-    Interface.print_ast = Stm.print_ast;
+    Interface.print_ast = print_ast;
     Interface.annotate = interruptible annotate;
   } in
   Xmlprotocol.abstract_eval_call handler c
@@ -427,22 +469,18 @@ let print_xml =
   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
+    with e -> let e = CErrors.push e in Mutex.unlock m; iraise e
 
 
-let slave_logger xml_oc level message =
+let slave_logger xml_oc ?loc 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
+  let msg = hov 0 message in
+  let () = pr_debug (Printf.sprintf "-> %S" (string_of_ppcmds msg))         in
+  let xml = Xmlprotocol.of_message level loc (Richpp.richpp_of_pp message) in
   print_xml xml_oc xml
 
 let slave_feeder xml_oc msg =
-  let xml = Feedback.of_feedback msg in
+  let xml = Xmlprotocol.of_feedback msg in
   print_xml xml_oc xml
 
 (** The main loop *)
@@ -460,8 +498,8 @@ let loop () =
     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);
+  Feedback.set_logger (slave_logger xml_oc);
+  Feedback.add_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;
@@ -469,9 +507,9 @@ let loop () =
     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 Xmlprotocol.Unknown 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 r = eval_call xml_oc (slave_logger xml_oc Feedback.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);
@@ -481,11 +519,11 @@ let loop () =
         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
+        pr_error ("XML syntax error: " ^ Xml_parser.error_msg err)
+      | Serialize.Marshal_error (msg,node) ->
+        pr_error "Unexpected XML message";
+        pr_error ("Expected XML node: " ^ msg);
+        pr_error ("XML tree received: " ^ Xml_printer.to_string_fmt node)
       | any ->
         pr_debug ("Fatal exception in coqtop:\n" ^ Printexc.to_string any);
         exit 1
diff --git a/ide/ideutils.ml b/ide/ideutils.ml
index 44a86556..06a13273 100644
--- a/ide/ideutils.ml
+++ b/ide/ideutils.ml
@@ -9,8 +9,6 @@
 
 open Preferences
 
-exception Forbidden
-
 let warn_image () =
   let img = GMisc.image () in
   img#set_stock `DIALOG_WARNING;
@@ -31,13 +29,54 @@ let push_info,pop_info,clear_info =
   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)
+  (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
     (fun ?(delay=5000) s -> flash_context#flash ~delay s)
 
-
+let xml_to_string xml =
+  let open Xml_datatype in
+  let buf = Buffer.create 1024 in
+  let rec iter = function
+  | PCData s -> Buffer.add_string buf s
+  | Element (_, _, children) ->
+    List.iter iter children
+  in
+  let () = iter (Richpp.repr xml) in
+  Buffer.contents buf
+
+let insert_with_tags (buf : #GText.buffer_skel) mark rmark tags text =
+  (** FIXME: LablGTK2 does not export the C insert_with_tags function, so that
+      it has to reimplement its own helper function. Unluckily, it relies on
+      a slow algorithm, so that we have to have our own quicker version here.
+      Alas, it is still much slower than the native version... *)
+  if CList.is_empty tags then buf#insert ~iter:(buf#get_iter_at_mark mark) text
+  else
+    let it = buf#get_iter_at_mark mark in
+    let () = buf#move_mark rmark ~where:it in
+    let () = buf#insert ~iter:(buf#get_iter_at_mark mark) text in
+    let start = buf#get_iter_at_mark mark in
+    let stop = buf#get_iter_at_mark rmark in
+    let iter tag = buf#apply_tag tag start stop in
+    List.iter iter tags
+
+let insert_xml ?(mark = `INSERT) ?(tags = []) (buf : #GText.buffer_skel) msg =
+  let open Xml_datatype in
+  let tag name =
+    match GtkText.TagTable.lookup buf#tag_table name with
+    | None -> raise Not_found
+    | Some tag -> new GText.tag tag
+  in
+  let rmark = `MARK (buf#create_mark buf#start_iter) in
+  let rec insert tags = function
+  | PCData s -> insert_with_tags buf mark rmark tags s
+  | Element (t, _, children) ->
+    let tags = try tag t :: tags with Not_found -> tags in
+    List.iter (fun xml -> insert tags xml) children
+  in
+  let () = try insert tags (Richpp.repr msg) with _ -> () in
+  buf#delete_mark rmark
 
 let set_location = ref  (function s -> failwith "not ready")
 
@@ -74,7 +113,7 @@ let do_convert s =
   in
   let s =
     if Glib.Utf8.validate s then (Minilib.log "Input is UTF-8"; s)
-    else match current.encoding with
+    else match encoding#get with
       |Preferences.Eutf8 | Preferences.Elocale -> from_loc ()
       |Emanual enc -> try from_manual enc with _ -> from_loc ()
   in
@@ -87,10 +126,28 @@ let try_convert s =
     "(* Fatal error: wrong encoding in input. \
 Please choose a correct encoding in the preference panel.*)";;
 
+let export file_name s =
+  let oc = open_out_bin file_name in
+  let ending = line_ending#get in
+  let is_windows = ref false in
+  for i = 0 to String.length s - 1 do
+    match s.[i] with
+    | '\r' -> is_windows := true
+    | '\n' ->
+      begin match ending with
+      | `DEFAULT ->
+        if !is_windows then (output_char oc '\r'; output_char oc '\n')
+        else output_char oc '\n'
+      | `WINDOWS -> output_char oc '\r'; output_char oc '\n'
+      | `UNIX -> output_char oc '\n'
+      end
+    | c -> output_char oc c
+  done;
+  close_out oc
 
 let try_export file_name s =
   let s =
-    try match current.encoding with
+    try match encoding#get with
       |Eutf8 -> Minilib.log "UTF-8 is enforced" ; s
       |Elocale ->
 	let is_unicode,char_set = Glib.Convert.get_charset () in
@@ -109,11 +166,7 @@ let try_export file_name s =
       Minilib.log ("Error ("^str^") in transcoding: falling back to UTF-8");
       s
   in
-  try
-    let oc = open_out file_name in
-    output_string oc s;
-    close_out oc;
-    true
+  try export file_name s; true
   with e -> Minilib.log (Printexc.to_string e);false
 
 type timer = { run : ms:int -> callback:(unit->bool) -> unit;
@@ -140,7 +193,7 @@ let filter_coq_files () =  GFile.filter
   ~name:"Coq source code"
   ~patterns:[ "*.v"] ()
 
-let current_dir () = match current.project_path with
+let current_dir () = match project_path#get with
 | None -> ""
 | Some dir -> dir
 
@@ -164,7 +217,7 @@ let select_file_for_open ~title ?filename () =
 	match file_chooser#filename with
 	  | None -> None
 	  | Some _ as f ->
-            current.project_path <- file_chooser#current_folder; f
+            project_path#set file_chooser#current_folder; f
       end
     | `DELETE_EVENT | `CANCEL -> None in
   file_chooser#destroy ();
@@ -193,7 +246,7 @@ let select_file_for_save ~title ?filename () =
         file := file_chooser#filename;
         match !file with
             None -> ()
-          | Some s -> current.project_path <- file_chooser#current_folder
+          | Some s -> project_path#set file_chooser#current_folder
       end
     | `DELETE_EVENT | `CANCEL -> ()
   end ;
@@ -238,7 +291,7 @@ let coqtop_path () =
   let file = match !custom_coqtop with
     | Some s -> s
     | None ->
-      match current.cmd_coqtop with
+      match cmd_coqtop#get with
 	| Some s -> s
 	| None ->
 	  let prog = String.copy Sys.executable_name in
@@ -272,17 +325,17 @@ let textview_width (view : #GText.view_skel) =
   let char_width = GPango.to_pixels metrics#approx_char_width in
   pixel_width / char_width
 
-type logger = Pp.message_level -> string -> unit
+type logger = Feedback.level -> Richpp.richpp -> 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
+  | Feedback.Debug -> `DEBUG
+  | Feedback.Info -> `INFO
+  | Feedback.Notice -> `NOTICE
+  | Feedback.Warning -> `WARNING
+  | Feedback.Error -> `ERROR
   in
-  Minilib.log ~level message
+  Minilib.log ~level (xml_to_string message)
 
 
 (** {6 File operations} *)
@@ -364,7 +417,7 @@ let run_command display finally cmd =
 (** Web browsing *)
 
 let browse prerr url =
-  let com = Util.subst_command_placeholder current.cmd_browse url in
+  let com = Util.subst_command_placeholder cmd_browse#get url in
   let finally = function
     | Unix.WEXITED 127 ->
       prerr
@@ -375,13 +428,13 @@ let browse prerr url =
   run_command (fun _ -> ()) finally com
 
 let doc_url () =
-  if current.doc_url = use_default_doc_url || current.doc_url = ""
+  if doc_url#get = use_default_doc_url || doc_url#get = ""
   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 doc_url#get
 
 let url_for_keyword =
   let ht = Hashtbl.create 97 in
diff --git a/ide/ideutils.mli b/ide/ideutils.mli
index e5307218..e32a4d9e 100644
--- a/ide/ideutils.mli
+++ b/ide/ideutils.mli
@@ -52,6 +52,11 @@ val pop_info : unit -> unit
 val clear_info : unit -> unit
 val flash_info : ?delay:int -> string -> unit
 
+val xml_to_string : Richpp.richpp -> string
+
+val insert_xml : ?mark:GText.mark -> ?tags:GText.tag list ->
+  #GText.buffer_skel -> Richpp.richpp -> unit
+
 val set_location : (string -> unit) ref
 
 (* In win32, when a command-line is to be executed via cmd.exe
@@ -64,9 +69,9 @@ 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
+type logger = Feedback.level -> Richpp.richpp -> unit
 
-val default_logger : Pp.message_level -> string -> unit
+val default_logger : logger
 (** Default logger. It logs messages that the casual user should not see. *)
 
 (** {6 I/O operations} *)
diff --git a/ide/interface.mli b/ide/interface.mli
index 6f7f1bcd..2a9b8b24 100644
--- a/ide/interface.mli
+++ b/ide/interface.mli
@@ -12,14 +12,15 @@
 
 type raw = bool
 type verbose = bool
+type richpp = Richpp.richpp
 
 (** The type of coqtop goals *)
 type goal = {
   goal_id : string;
   (** Unique goal identifier *)
-  goal_hyp : string list;
+  goal_hyp : richpp list;
   (** List of hypotheses *)
-  goal_ccl : string;
+  goal_ccl : richpp;
   (** Goal conclusion *)
 }
 
@@ -118,7 +119,7 @@ type edit_id = Feedback.edit_id
    should probably retract to that point *)
 type 'a value =
   | Good of 'a
-  | Fail of (state_id * location * string)
+  | Fail of (state_id * location * richpp)
 
 type ('a, 'b) union = ('a, 'b) Util.union
 
@@ -202,7 +203,7 @@ type about_sty = unit
 type about_rty = coq_info
 
 type handle_exn_sty = Exninfo.iexn
-type handle_exn_rty = state_id * location * string
+type handle_exn_rty = state_id * location * richpp
 
 (* Retrocompatibility stuff *)
 type interp_sty = (raw * verbose) * string
diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml
index 42d65cec..93bdeb32 100644
--- a/ide/nanoPG.ml
+++ b/ide/nanoPG.ml
@@ -303,7 +303,7 @@ let init w nb ags =
     then false
     else begin
     eprintf "got key %s\n%!" (pr_key t);
-    if current.nanoPG then begin
+    if nanoPG#get then begin
       match find gui !cur t with
       | `Do e ->
            eprintf "run (%s) %s on %s\n%!" e.keyname e.doc (pr_status !status);
diff --git a/ide/preferences.ml b/ide/preferences.ml
index f7cc27a5..f0fd45d7 100644
--- a/ide/preferences.ml
+++ b/ide/preferences.ml
@@ -17,19 +17,67 @@ 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.coqide_config_dirs ()) in
-  Filename.concat config_dir name
+type tag = {
+  tag_fg_color : string option;
+  tag_bg_color : string option;
+  tag_bold : bool;
+  tag_italic : bool;
+  tag_underline : bool;
+}
 
-(* 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 (Option.default "" (Glib.get_home_dir ())) ".coqiderc"
+(** Generic preferences *)
 
-let loaded_accel_file =
-  try get_config_file "coqide.keys"
-  with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqide.keys"
+type obj = {
+  set : string list -> unit;
+  get : unit -> string list;
+}
+
+let preferences : obj Util.String.Map.t ref = ref Util.String.Map.empty
+let unknown_preferences : string list Util.String.Map.t ref = ref Util.String.Map.empty
+
+class type ['a] repr =
+object
+  method into : string list -> 'a option
+  method from : 'a -> string list
+end
+
+class ['a] preference_signals ~(changed : 'a GUtil.signal) =
+object
+  inherit GUtil.ml_signals [changed#disconnect]
+  method changed = changed#connect ~after
+end
+
+class ['a] preference ~(name : string list) ~(init : 'a) ~(repr : 'a repr) =
+object (self)
+  initializer
+    let set v = match repr#into v with None -> () | Some s -> self#set s in
+    let get () = repr#from self#get in
+    let obj = { set = set; get = get; } in
+    let name = String.concat "." name in
+    if Util.String.Map.mem name !preferences then
+      invalid_arg ("Preference " ^ name ^ " already exists")
+    else
+      preferences := Util.String.Map.add name obj !preferences
+
+  val default = init
+  val mutable data = init
+  val changed : 'a GUtil.signal = new GUtil.signal ()
+  val name : string list = name
+  method connect = new preference_signals ~changed
+  method get = data
+  method set (n : 'a) = data <- n; changed#call n
+  method reset () = self#set default
+  method default = default
+end
+
+let stick (pref : 'a preference) (obj : #GObj.widget as 'obj)
+  (cb : 'a -> unit) =
+  let _ = cb pref#get in
+  let p_id = pref#connect#changed (fun v -> cb v) in
+  let _ = obj#misc#connect#destroy (fun () -> pref#connect#disconnect p_id) in
+  ()
+
+(** Useful marshallers *)
 
 let mod_to_str m =
   match m with
@@ -74,359 +122,537 @@ let inputenc_of_string s =
        else if s = "LOCALE" then Elocale
        else Emanual s)
 
+type line_ending = [ `DEFAULT | `WINDOWS | `UNIX ]
+
+let line_end_of_string = function
+| "unix" -> `UNIX
+| "windows" -> `WINDOWS
+| _ -> `DEFAULT
+
+let line_end_to_string = function
+| `UNIX -> "unix"
+| `WINDOWS -> "windows"
+| `DEFAULT -> "default"
+
+let use_default_doc_url = "(automatic)"
+
+module Repr =
+struct
+
+let string : string repr =
+object
+  method from s = [s]
+  method into = function [s] -> Some s | _ -> None
+end
+
+let string_pair : (string * string) repr =
+object
+  method from (s1, s2) = [s1; s2]
+  method into = function [s1; s2] -> Some (s1, s2) | _ -> None
+end
+
+let string_list : string list repr =
+object
+  method from s = s
+  method into s = Some s
+end
+
+let string_pair_list (sep : char) : (string * string) list repr =
+object
+  val sep' = String.make 1 sep
+  method from = CList.map (fun (s1, s2) -> CString.concat sep' [s1; s2])
+  method into l =
+    try
+      Some (CList.map (fun s ->
+        let split = CString.split sep s in
+        CList.nth split 0, CList.nth split 1) l)
+    with Failure _ -> None
+end
+
+let bool : bool repr =
+object
+  method from s = [string_of_bool s]
+  method into = function
+  | ["true"] -> Some true
+  | ["false"] -> Some false
+  | _ -> None
+end
+
+let int : int repr =
+object
+  method from s = [string_of_int s]
+  method into = function
+  | [i] -> (try Some (int_of_string i) with _ -> None)
+  | _ -> None
+end
+
+let option (r : 'a repr) : 'a option repr =
+object
+  method from = function None -> [] | Some v -> "" :: r#from v
+  method into = function
+  | [] -> Some None
+  | "" :: s -> Some (r#into s)
+  | _ -> None
+end
+
+let custom (from : 'a -> string) (into : string -> 'a) : 'a repr =
+object
+  method from x = try [from x] with _ -> []
+  method into = function
+  | [s] -> (try Some (into s) with _ -> None)
+  | _ -> None
+end
+
+let tag : tag repr =
+let _to s = if s = "" then None else Some s in
+let _of = function None -> "" | Some s -> s in
+object
+  method from tag = [
+    _of tag.tag_fg_color;
+    _of tag.tag_bg_color;
+    string_of_bool tag.tag_bold;
+    string_of_bool tag.tag_italic;
+    string_of_bool tag.tag_underline;
+  ]
+  method into = function
+  | [fg; bg; bd; it; ul] ->
+    (try Some {
+      tag_fg_color = _to fg;
+      tag_bg_color = _to bg;
+      tag_bold = bool_of_string bd;
+      tag_italic = bool_of_string it;
+      tag_underline = bool_of_string ul;
+      }
+    with _ -> None)
+  | _ -> None
+end
+
+end
+
+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.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 (Option.default "" (Glib.get_home_dir ())) ".coqiderc"
+
+let loaded_accel_file =
+  try get_config_file "coqide.keys"
+  with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqide.keys"
 
 (** Hooks *)
 
-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 contextual_menus_on_goal_hook = ref (fun x -> ())
-let resize_window_hook = ref (fun () -> ())
-let refresh_tabs_hook = ref (fun () -> ())
+(** New style preferences *)
 
-type pref =
-    {
-      mutable cmd_coqtop : string option;
-      mutable cmd_coqc : string;
-      mutable cmd_make : string;
-      mutable cmd_coqmakefile : string;
-      mutable cmd_coqdoc : string;
+let cmd_coqtop =
+  new preference ~name:["cmd_coqtop"] ~init:None ~repr:Repr.(option string)
 
-      mutable source_language : string;
-      mutable source_style : string;
+let cmd_coqc =
+  new preference ~name:["cmd_coqc"] ~init:"coqc" ~repr:Repr.(string)
 
-      mutable global_auto_revert : bool;
-      mutable global_auto_revert_delay : int;
+let cmd_make =
+  new preference ~name:["cmd_make"] ~init:"make" ~repr:Repr.(string)
 
-      mutable auto_save : bool;
-      mutable auto_save_delay : int;
-      mutable auto_save_name : string * string;
+let cmd_coqmakefile =
+  new preference ~name:["cmd_coqmakefile"] ~init:"coq_makefile -o makefile *.v" ~repr:Repr.(string)
 
-      mutable read_project : project_behavior;
-      mutable project_file_name : string;
-      mutable project_path : string option;
+let cmd_coqdoc =
+  new preference ~name:["cmd_coqdoc"] ~init:"coqdoc -q -g" ~repr:Repr.(string)
 
-      mutable encoding : inputenc;
+let source_language =
+  new preference ~name:["source_language"] ~init:"coq" ~repr:Repr.(string)
 
-      mutable automatic_tactics : string list;
-      mutable cmd_print : string;
+let source_style =
+  new preference ~name:["source_style"] ~init:"coq_style" ~repr:Repr.(string)
 
-      mutable modifier_for_navigation : string;
-      mutable modifier_for_templates : string;
-      mutable modifier_for_tactics : string;
-      mutable modifier_for_display : string;
-      mutable modifiers_valid : string;
+let global_auto_revert =
+  new preference ~name:["global_auto_revert"] ~init:false ~repr:Repr.(bool)
 
-      mutable cmd_browse : string;
-      mutable cmd_editor : string;
+let global_auto_revert_delay =
+  new preference ~name:["global_auto_revert_delay"] ~init:10000 ~repr:Repr.(int)
 
-      mutable text_font : Pango.font_description;
+let auto_save =
+  new preference ~name:["auto_save"] ~init:true ~repr:Repr.(bool)
 
-      mutable doc_url : string;
-      mutable library_url : string;
+let auto_save_delay =
+  new preference ~name:["auto_save_delay"] ~init:10000 ~repr:Repr.(int)
 
-      mutable show_toolbar : bool;
-      mutable contextual_menus_on_goal : bool;
-      mutable window_width : int;
-      mutable window_height :int;
-      mutable query_window_width : int;
-      mutable query_window_height : int;
-(*
-      mutable use_utf8_notation : bool;
-*)
-      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 error_fg_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 auto_save_name =
+  new preference ~name:["auto_save_name"] ~init:("#","#") ~repr:Repr.(string_pair)
+
+let read_project =
+  let repr = Repr.custom string_of_project_behavior project_behavior_of_string in
+  new preference ~name:["read_project"] ~init:Append_args ~repr
+
+let project_file_name =
+  new preference ~name:["project_file_name"] ~init:"_CoqProject" ~repr:Repr.(string)
+
+let project_path =
+  new preference ~name:["project_path"] ~init:None ~repr:Repr.(option string)
+
+let encoding =
+  let repr = Repr.custom string_of_inputenc inputenc_of_string in
+  let init = if Sys.os_type = "Win32" then Eutf8 else Elocale in
+  new preference ~name:["encoding"] ~init ~repr
+
+let automatic_tactics =
+  let init = ["trivial"; "tauto"; "auto"; "omega"; "auto with *"; "intuition" ] in
+  new preference ~name:["automatic_tactics"] ~init ~repr:Repr.(string_list)
 
+let cmd_print =
+  new preference ~name:["cmd_print"] ~init:"lpr" ~repr:Repr.(string)
+
+let attach_modifiers (pref : string preference) prefix =
+  let cb mds =
+    let mds = str_to_mod_list mds in
+    let change ~path ~key ~modi ~changed =
+      if CString.is_sub prefix path 0 then
+        ignore (GtkData.AccelMap.change_entry ~key ~modi:mds ~replace:true path)
+    in
+    GtkData.AccelMap.foreach change
+  in
+  pref#connect#changed cb
+
+let modifier_for_navigation =
+  new preference ~name:["modifier_for_navigation"] ~init:"<Control>" ~repr:Repr.(string)
+
+let modifier_for_templates =
+  new preference ~name:["modifier_for_templates"] ~init:"<Control><Shift>" ~repr:Repr.(string)
+ 
+let modifier_for_tactics =
+  new preference ~name:["modifier_for_tactics"] ~init:"<Control><Alt>" ~repr:Repr.(string)
+
+let modifier_for_display =
+  new preference ~name:["modifier_for_display"] ~init:"<Alt><Shift>" ~repr:Repr.(string)
+
+let modifier_for_queries =
+  new preference ~name:["modifier_for_queries"] ~init:"<Control><Shift>" ~repr:Repr.(string)
+
+let _ = attach_modifiers modifier_for_navigation "<Actions>/Navigation/"
+let _ = attach_modifiers modifier_for_templates "<Actions>/Templates/"
+let _ = attach_modifiers modifier_for_tactics "<Actions>/Tactics/"
+let _ = attach_modifiers modifier_for_display "<Actions>/View/"
+let _ = attach_modifiers modifier_for_queries "<Actions>/Queries/"
+
+let modifiers_valid =
+  new preference ~name:["modifiers_valid"] ~init:"<Alt><Control><Shift>" ~repr:Repr.(string)
+
+let cmd_browse =
+  new preference ~name:["cmd_browse"] ~init:Flags.browser_cmd_fmt ~repr:Repr.(string)
+
+let cmd_editor =
+  let init = if Sys.os_type = "Win32" then "NOTEPAD %s" else "emacs %s" in
+  new preference ~name:["cmd_editor"] ~init ~repr:Repr.(string)
+
+let text_font =
+  let init = match Coq_config.gtk_platform with
+  | `QUARTZ -> "Arial Unicode MS 11"
+  | _ -> "Monospace 10"
+  in
+  new preference ~name:["text_font"] ~init ~repr:Repr.(string)
+
+let doc_url =
+object
+  inherit [string] preference
+    ~name:["doc_url"] ~init:Coq_config.wwwrefman ~repr:Repr.(string)
+    as super
+
+  method set v =
+    if not (Flags.is_standard_doc_url v) &&
+      v <> use_default_doc_url &&
+      (* Extra hack to support links to last released doc version *)
+      v <> Coq_config.wwwcoq ^ "doc" &&
+      v <> Coq_config.wwwcoq ^ "doc/"
+    then super#set v
+
+end
+
+let library_url =
+  new preference ~name:["library_url"] ~init:Coq_config.wwwstdlib ~repr:Repr.(string)
+
+let show_toolbar =
+  new preference ~name:["show_toolbar"] ~init:true ~repr:Repr.(bool)
+
+let contextual_menus_on_goal =
+  new preference ~name:["contextual_menus_on_goal"] ~init:true ~repr:Repr.(bool)
+
+let window_width =
+  new preference ~name:["window_width"] ~init:800 ~repr:Repr.(int)
+
+let window_height =
+  new preference ~name:["window_height"] ~init:600 ~repr:Repr.(int)
+
+let auto_complete =
+  new preference ~name:["auto_complete"] ~init:false ~repr:Repr.(bool)
+
+let stop_before =
+  new preference ~name:["stop_before"] ~init:true ~repr:Repr.(bool)
+
+let reset_on_tab_switch =
+  new preference ~name:["reset_on_tab_switch"] ~init:false ~repr:Repr.(bool)
+
+let line_ending =
+  let repr = Repr.custom line_end_to_string line_end_of_string in
+  new preference ~name:["line_ending"] ~init:`DEFAULT ~repr
+
+let vertical_tabs =
+  new preference ~name:["vertical_tabs"] ~init:false ~repr:Repr.(bool)
+
+let opposite_tabs =
+  new preference ~name:["opposite_tabs"] ~init:false ~repr:Repr.(bool)
+
+let background_color =
+  new preference ~name:["background_color"] ~init:"cornsilk" ~repr:Repr.(string)
+
+let attach_bg (pref : string preference) (tag : GText.tag) =
+  pref#connect#changed (fun c -> tag#set_property (`BACKGROUND c))
+
+let attach_fg (pref : string preference) (tag : GText.tag) =
+  pref#connect#changed (fun c -> tag#set_property (`FOREGROUND c))
+
+let processing_color =
+  new preference ~name:["processing_color"] ~init:"light blue" ~repr:Repr.(string)
+
+let _ = attach_bg processing_color Tags.Script.to_process
+let _ = attach_bg processing_color Tags.Script.incomplete
+
+let tags = ref Util.String.Map.empty
+
+let list_tags () = !tags
+
+let make_tag ?fg ?bg ?(bold = false) ?(italic = false) ?(underline = false) () = {
+  tag_fg_color = fg;
+  tag_bg_color = bg;
+  tag_bold = bold;
+  tag_italic = italic;
+  tag_underline = underline;
 }
 
-let use_default_doc_url = "(automatic)"
+let create_tag name default =
+  let pref = new preference ~name:[name] ~init:default ~repr:Repr.(tag) in
+  let set_tag tag =
+    begin match pref#get.tag_bg_color with
+    | None -> tag#set_property (`BACKGROUND_SET false)
+    | Some c ->
+      tag#set_property (`BACKGROUND_SET true);
+      tag#set_property (`BACKGROUND c)
+    end;
+    begin match pref#get.tag_fg_color with
+    | None -> tag#set_property (`FOREGROUND_SET false)
+    | Some c ->
+      tag#set_property (`FOREGROUND_SET true);
+      tag#set_property (`FOREGROUND c)
+    end;
+    begin match pref#get.tag_bold with
+    | false -> tag#set_property (`WEIGHT_SET false)
+    | true ->
+      tag#set_property (`WEIGHT_SET true);
+      tag#set_property (`WEIGHT `BOLD)
+    end;
+    begin match pref#get.tag_italic with
+    | false -> tag#set_property (`STYLE_SET false)
+    | true ->
+      tag#set_property (`STYLE_SET true);
+      tag#set_property (`STYLE `ITALIC)
+    end;
+    begin match pref#get.tag_underline with
+    | false -> tag#set_property (`UNDERLINE_SET false)
+    | true ->
+      tag#set_property (`UNDERLINE_SET true);
+      tag#set_property (`UNDERLINE `SINGLE)
+    end;
+  in
+  let iter table =
+    let tag = GText.tag ~name () in
+    table#add tag#as_tag;
+    ignore (pref#connect#changed (fun _ -> set_tag tag));
+    set_tag tag;
+  in
+  List.iter iter [Tags.Script.table; Tags.Proof.table; Tags.Message.table];
+  tags := Util.String.Map.add name pref !tags
 
-let current = {
-    cmd_coqtop = None;
-    cmd_coqc = "coqc";
-    cmd_make = "make";
-    cmd_coqmakefile = "coq_makefile -o makefile *.v";
-    cmd_coqdoc = "coqdoc -q -g";
-    cmd_print = "lpr";
+let () =
+  let iter (name, tag) = create_tag name tag in
+  List.iter iter [
+    ("constr.evar", make_tag ());
+    ("constr.keyword", make_tag ~fg:"dark green" ());
+    ("constr.notation", make_tag ());
+    ("constr.path", make_tag ());
+    ("constr.reference", make_tag ~fg:"navy"());
+    ("constr.type", make_tag ~fg:"#008080" ());
+    ("constr.variable", make_tag ());
+    ("message.debug", make_tag ());
+    ("message.error", make_tag ());
+    ("message.warning", make_tag ());
+    ("module.definition", make_tag ~fg:"orange red" ~bold:true ());
+    ("module.keyword", make_tag ());
+    ("tactic.keyword", make_tag ());
+    ("tactic.primitive", make_tag ());
+    ("tactic.string", make_tag ());
+  ]
 
-    global_auto_revert = false;
-    global_auto_revert_delay = 10000;
+let processed_color =
+  new preference ~name:["processed_color"] ~init:"light green" ~repr:Repr.(string)
 
-    auto_save = true;
-    auto_save_delay = 10000;
-    auto_save_name = "#","#";
+let _ = attach_bg processed_color Tags.Script.processed
+let _ = attach_bg processed_color Tags.Proof.highlight
 
-    source_language = "coq";
-    source_style = "coq_style";
+let error_color =
+  new preference ~name:["error_color"] ~init:"#FFCCCC" ~repr:Repr.(string)
 
-    read_project = Append_args;
-    project_file_name = "_CoqProject";
-    project_path = None;
+let _ = attach_bg error_color Tags.Script.error_bg
 
-    encoding = if Sys.os_type = "Win32" then Eutf8 else Elocale;
+let error_fg_color =
+  new preference ~name:["error_fg_color"] ~init:"red" ~repr:Repr.(string)
 
-    automatic_tactics = ["trivial"; "tauto"; "auto"; "omega";
-			 "auto with *"; "intuition" ];
+let _ = attach_fg error_fg_color Tags.Script.error
 
-    modifier_for_navigation = "<Control>";
-    modifier_for_templates = "<Control><Shift>";
-    modifier_for_tactics = "<Control><Alt>";
-    modifier_for_display = "<Alt><Shift>";
-    modifiers_valid = "<Alt><Control><Shift>";
+let dynamic_word_wrap =
+  new preference ~name:["dynamic_word_wrap"] ~init:false ~repr:Repr.(bool)
 
+let show_line_number =
+  new preference ~name:["show_line_number"] ~init:false ~repr:Repr.(bool)
 
-    cmd_browse = Flags.browser_cmd_fmt;
-    cmd_editor = if Sys.os_type = "Win32" then "NOTEPAD %s" else "emacs %s";
+let auto_indent =
+  new preference ~name:["auto_indent"] ~init:false ~repr:Repr.(bool)
 
-(*    text_font = Pango.Font.from_string "sans 12";*)
-    text_font = Pango.Font.from_string (match Coq_config.gtk_platform with
-					  |`QUARTZ -> "Arial Unicode MS 11"
-					  |_ -> "Monospace 10");
+let show_spaces =
+  new preference ~name:["show_spaces"] ~init:true ~repr:Repr.(bool)
 
-    doc_url = Coq_config.wwwrefman;
-    library_url = Coq_config.wwwstdlib;
+let show_right_margin =
+  new preference ~name:["show_right_margin"] ~init:false ~repr:Repr.(bool)
 
-    show_toolbar = true;
-    contextual_menus_on_goal = true;
-    window_width = 800;
-    window_height = 600;
-    query_window_width = 600;
-    query_window_height = 400;
-(*
-    use_utf8_notation = false;
-*)
-    auto_complete = false;
-    stop_before = true;
-    reset_on_tab_switch = false;
-    vertical_tabs = false;
-    opposite_tabs = false;
-
-    background_color = Tags.default_color;
-    processed_color = Tags.default_processed_color;
-    processing_color = Tags.default_processing_color;
-    error_color = Tags.default_error_color;
-    error_fg_color = Tags.default_error_fg_color;
-
-    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 show_progress_bar =
+  new preference ~name:["show_progress_bar"] ~init:true ~repr:Repr.(bool)
+
+let spaces_instead_of_tabs =
+  new preference ~name:["spaces_instead_of_tabs"] ~init:true ~repr:Repr.(bool)
+
+let tab_length =
+  new preference ~name:["tab_length"] ~init:2 ~repr:Repr.(int)
+
+let highlight_current_line =
+  new preference ~name:["highlight_current_line"] ~init:false ~repr:Repr.(bool)
+
+let nanoPG =
+  new preference ~name:["nanoPG"] ~init:false ~repr:Repr.(bool)
+
+let user_queries =
+  new preference ~name:["user_queries"] ~init:[] ~repr:Repr.(string_pair_list '$')
+
+class tag_button (box : Gtk.box Gtk.obj) =
+object (self)
+
+  inherit GObj.widget box
+
+  val fg_color = GButton.color_button ()
+  val fg_unset = GButton.toggle_button ()
+  val bg_color = GButton.color_button ()
+  val bg_unset = GButton.toggle_button ()
+  val bold = GButton.toggle_button ()
+  val italic = GButton.toggle_button ()
+  val underline = GButton.toggle_button ()
+
+  method set_tag tag =
+    let track c but set = match c with
+    | None -> set#set_active true
+    | Some c ->
+      set#set_active false;
+      but#set_color (Tags.color_of_string c)
+    in
+    track tag.tag_bg_color bg_color bg_unset;
+    track tag.tag_fg_color fg_color fg_unset;
+    bold#set_active tag.tag_bold;
+    italic#set_active tag.tag_italic;
+    underline#set_active tag.tag_underline;
+
+  method tag =
+    let get but set =
+      if set#active then None
+      else Some (Tags.string_of_color but#color)
+    in
+    {
+      tag_bg_color = get bg_color bg_unset;
+      tag_fg_color = get fg_color fg_unset;
+      tag_bold = bold#active;
+      tag_italic = italic#active;
+      tag_underline = underline#active;
+    }
+
+  initializer
+    let box = new GPack.box box in
+    let set_stock button stock =
+      let stock = GMisc.image ~stock ~icon_size:`BUTTON () in
+      button#set_image stock#coerce
+    in
+    set_stock fg_unset `CANCEL;
+    set_stock bg_unset `CANCEL;
+    set_stock bold `BOLD;
+    set_stock italic `ITALIC;
+    set_stock underline `UNDERLINE;
+    box#pack fg_color#coerce;
+    box#pack fg_unset#coerce;
+    box#pack bg_color#coerce;
+    box#pack bg_unset#coerce;
+    box#pack bold#coerce;
+    box#pack italic#coerce;
+    box#pack underline#coerce;
+    let cb but obj = obj#set_sensitive (not but#active) in
+    let _ = fg_unset#connect#toggled (fun () -> cb fg_unset fg_color#misc) in
+    let _ = bg_unset#connect#toggled (fun () -> cb bg_unset bg_color#misc) in
+    ()
+
+end
+
+let tag_button () =
+  let box = GPack.hbox () in
+  new tag_button (Gobject.unsafe_cast box#as_widget)
+
+(** Old style preferences *)
 
 let save_pref () =
   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 add = Util.String.Map.add in
-    let (++) x f = f x in
-    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] ++
-    add "auto_save" [string_of_bool p.auto_save] ++
-    add "auto_save_delay" [string_of_int p.auto_save_delay] ++
-    add "auto_save_name" [fst p.auto_save_name; snd p.auto_save_name] ++
-
-    add "project_options" [string_of_project_behavior p.read_project] ++
-    add "project_file_name" [p.project_file_name] ++
-    add "project_path" (match p.project_path with None -> [] | Some s -> [s]) ++
-
-    add "encoding" [string_of_inputenc p.encoding] ++
-
-    add "automatic_tactics" p.automatic_tactics ++
-    add "cmd_print" [p.cmd_print] ++
-    add "modifier_for_navigation" [p.modifier_for_navigation] ++
-    add "modifier_for_templates" [p.modifier_for_templates] ++
-    add "modifier_for_tactics" [p.modifier_for_tactics] ++
-    add "modifier_for_display" [p.modifier_for_display] ++
-    add "modifiers_valid" [p.modifiers_valid] ++
-    add "cmd_browse" [p.cmd_browse] ++
-    add "cmd_editor" [p.cmd_editor] ++
-
-    add "text_font" [Pango.Font.to_string p.text_font] ++
-
-    add "doc_url" [p.doc_url] ++
-    add "library_url" [p.library_url] ++
-    add "show_toolbar" [string_of_bool p.show_toolbar] ++
-    add "contextual_menus_on_goal"
-      [string_of_bool p.contextual_menus_on_goal] ++
-    add "window_height" [string_of_int p.window_height] ++
-    add "window_width" [string_of_int p.window_width] ++
-    add "query_window_height" [string_of_int p.query_window_height] ++
-    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 "error_fg_color" [p.error_fg_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 add = Util.String.Map.add in
+  let fold key obj accu = add key (obj.get ()) accu in
+  let prefs = Util.String.Map.fold fold !preferences Util.String.Map.empty in
+  let prefs = Util.String.Map.fold Util.String.Map.add !unknown_preferences prefs in
+  Config_lexer.print_file pref_file prefs
 
 let load_pref () =
   let () = try GtkData.AccelMap.load loaded_accel_file with _ -> () in
 
     let m = Config_lexer.load_file loaded_pref_file 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
-    let set_pair k f = set k (function [v1;v2] -> f v1 v2 | _ -> raise Exit) in
-    let set_command_with_pair_compat k f =
-      set k (function [v1;v2] -> f (v1^"%s"^v2) | [v] -> f v | _ -> raise Exit)
+    let iter name v =
+      if Util.String.Map.mem name !preferences then
+        try (Util.String.Map.find name !preferences).set v with _ -> ()
+      else unknown_preferences := Util.String.Map.add name v !unknown_preferences
     in
-    let set_option k f = set k (fun v -> f (match v with |[] -> None |h::_ ->  Some h)) in
-    set_option "cmd_coqtop" (fun v -> np.cmd_coqtop <- v);
-    set_hd "cmd_coqc" (fun v -> np.cmd_coqc <- v);
-    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);
-    set_bool "auto_save" (fun v -> np.auto_save <- v);
-    set_int "auto_save_delay" (fun v -> np.auto_save_delay <- v);
-    set_pair "auto_save_name" (fun v1 v2 -> np.auto_save_name <- (v1,v2));
-    set_hd "encoding" (fun v -> np.encoding <- (inputenc_of_string v));
-    set_hd "project_options"
-      (fun v -> np.read_project <- (project_behavior_of_string v));
-    set_hd "project_file_name" (fun v -> np.project_file_name <- v);
-    set_option "project_path" (fun v -> np.project_path <- v);
-    set "automatic_tactics"
-      (fun v -> np.automatic_tactics <- v);
-    set_hd "cmd_print" (fun v -> np.cmd_print <- v);
-    set_hd "modifier_for_navigation"
-      (fun v -> np.modifier_for_navigation <- v);
-    set_hd "modifier_for_templates"
-      (fun v -> np.modifier_for_templates <- v);
-    set_hd "modifier_for_tactics"
-      (fun v -> np.modifier_for_tactics <- v);
-    set_hd "modifier_for_display"
-      (fun v -> np.modifier_for_display <- v);
-    set_hd "modifiers_valid"
-      (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);
-    set_hd "doc_url" (fun v ->
-      if not (Flags.is_standard_doc_url v) &&
-        v <> use_default_doc_url &&
-	(* Extra hack to support links to last released doc version *)
-        v <> Coq_config.wwwcoq ^ "doc" &&
-	v <> Coq_config.wwwcoq ^ "doc/"
-      then
-	(* ("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);
-    set_bool "contextual_menus_on_goal"
-      (fun v -> np.contextual_menus_on_goal <- v);
-    set_int "window_width" (fun v -> np.window_width <- v);
-    set_int "window_height" (fun v -> np.window_height <- v);
-    set_int "query_window_width" (fun v -> np.query_window_width <- v);
-    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);
-    set_hd "error_color" (fun v -> np.error_color <- v);
-    set_hd "error_fg_color" (fun v -> np.error_fg_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);
-    ()
+    Util.String.Map.iter iter m
+
+let pstring name p = string ~f:p#set name p#get
+let pbool name p = bool ~f:p#set name p#get
+let pmodifiers ?(all = false) name p = modifiers
+  ?allow:(if all then None else Some (str_to_mod_list modifiers_valid#get))
+  ~f:(fun l -> p#set (mod_list_to_str l))
+  ~help:"restart to apply"
+  name
+  (str_to_mod_list p#get)
 
 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
-  let cmd_coqc =
-    string
-      ~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
-  let cmd_coqmakefile =
-    string
-      ~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
-  let cmd_print =
-    string
-      ~f:(fun s -> current.cmd_print <- s)
-      "   Print ps" current.cmd_print in
+      ~f:(fun s -> cmd_coqtop#set (if s = "AUTO" then None else Some s))
+      "       coqtop" (match cmd_coqtop#get with |None -> "AUTO" | Some x -> x) in
+  let cmd_coqc = pstring "       coqc" cmd_coqc in
+  let cmd_make = pstring "       make" cmd_make in
+  let cmd_coqmakefile = pstring "coqmakefile" cmd_coqmakefile in
+  let cmd_coqdoc = pstring "     coqdoc" cmd_coqdoc in
+  let cmd_print = pstring "   Print ps" cmd_print in
 
   let config_font =
     let box = GPack.hbox () in
@@ -435,18 +661,13 @@ let configure ?(apply=(fun () -> ())) () =
       "Goal (∃n : nat, n ≤ 0)∧(∀x,y,z, x∈y⋃z↔x∈y∨x∈z).";
     box#pack ~expand:true w#coerce;
     ignore (w#misc#connect#realize
-	      ~callback:(fun () -> w#set_font_name
-			   (Pango.Font.to_string current.text_font)));
+	      ~callback:(fun () -> w#set_font_name text_font#get));
     custom
       ~label:"Fonts for text"
       box
       (fun () ->
 	 let fd =  w#font_name in
-	 current.text_font <- (Pango.Font.from_string fd) ;
-(*
-	 Format.printf "in config_font: current.text_font = %s@." (Pango.Font.to_string current.text_font);
-*)
-	 !refresh_editor_hook ())
+	 text_font#set fd)
       true
   in
 
@@ -458,121 +679,94 @@ let configure ?(apply=(fun () -> ())) () =
       ~border_width:2
       ~packing:(box#pack ~expand:true) ()
     in
-    let background_label = GMisc.label
-      ~text:"Background color"
-      ~packing:(table#attach ~expand:`X ~left:0 ~top:0) ()
-    in
-    let processed_label = GMisc.label
-      ~text:"Background color of processed text"
-      ~packing:(table#attach ~expand:`X ~left:0 ~top:1) ()
-    in
-    let processing_label = GMisc.label
-      ~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 error_fg_label = GMisc.label
-      ~text:"Foreground color of errors"
-      ~packing:(table#attach ~expand:`X ~left:0 ~top:4) ()
-    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 () = error_fg_label#set_xalign 0. in
-    let background_button = GButton.color_button
-      ~color:(Tags.color_of_string (current.background_color))
-      ~packing:(table#attach ~left:1 ~top:0) ()
-    in
-    let processed_button = GButton.color_button
-      ~color:(Tags.get_processed_color ())
-      ~packing:(table#attach ~left:1 ~top:1) ()
-    in
-    let processing_button = GButton.color_button
-      ~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 error_fg_button = GButton.color_button
-      ~color:(Tags.get_error_fg_color ())
-      ~packing:(table#attach ~left:1 ~top:4) ()
-    in
     let reset_button = GButton.button
       ~label:"Reset"
       ~packing:box#pack ()
     in
-    let reset_cb () =
-      background_button#set_color Tags.(color_of_string default_color);
-      processing_button#set_color Tags.(color_of_string default_processing_color);
-      processed_button#set_color Tags.(color_of_string default_processed_color);
-      error_button#set_color Tags.(color_of_string default_error_color);
+    let iter i (text, pref) =
+      let label = GMisc.label
+        ~text ~packing:(table#attach ~expand:`X ~left:0 ~top:i) ()
+      in
+      let () = label#set_xalign 0. in
+      let button = GButton.color_button
+        ~color:(Tags.color_of_string pref#get)
+        ~packing:(table#attach ~left:1 ~top:i) ()
+      in
+      let _ = button#connect#color_set begin fun () ->
+        pref#set (Tags.string_of_color button#color)
+      end in
+      let reset _ =
+        pref#reset ();
+        button#set_color Tags.(color_of_string pref#get)
+      in
+      let _ = reset_button#connect#clicked ~callback:reset in
+      ()
     in
-    let _ = reset_button#connect#clicked ~callback:reset_cb in
+    let () = Util.List.iteri iter [
+      ("Background color", background_color);
+      ("Background color of processed text", processed_color);
+      ("Background color of text being processed", processing_color);
+      ("Background color of errors", error_color);
+      ("Foreground color of errors", error_fg_color);
+    ] 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;
-      current.error_color <- Tags.string_of_color error_button#color;
-      current.error_fg_color <- Tags.string_of_color error_fg_button#color;
-      !refresh_editor_hook ();
-      Tags.set_processing_color processing_button#color;
-      Tags.set_processed_color processed_button#color;
-      Tags.set_error_color error_button#color;
-      Tags.set_error_fg_color error_fg_button#color
+    let callback () = () in
+    custom ~label box callback true
+  in
+
+  let config_tags =
+    let box = GPack.vbox () in
+    let scroll = GBin.scrolled_window
+      ~hpolicy:`NEVER
+      ~vpolicy:`AUTOMATIC
+      ~packing:(box#pack ~expand:true)
+      ()
     in
+    let table = GPack.table
+      ~row_spacings:5
+      ~col_spacings:5
+      ~border_width:2
+      ~packing:scroll#add_with_viewport ()
+    in
+    let i = ref 0 in
+    let cb = ref [] in
+    let iter text tag =
+      let label = GMisc.label
+        ~text ~packing:(table#attach ~expand:`X ~left:0 ~top:!i) ()
+      in
+      let () = label#set_xalign 0. in
+      let button = tag_button () in
+      let callback () = tag#set button#tag in
+      button#set_tag tag#get;
+      table#attach ~left:1 ~top:!i button#coerce;
+      incr i;
+      cb := callback :: !cb;
+    in
+    let () = Util.String.Map.iter iter !tags in
+    let label = "Tag configuration" in
+    let callback () = List.iter (fun f -> f ()) !cb 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 ()
+    let button text (pref : bool preference) =
+      let active = pref#get in
+      let but = GButton.check_button ~label:text ~active ~packing:box#pack () in
+      ignore (but#connect#toggled (fun () -> pref#set but#active))
     in
+    let () = button "Dynamic word wrap" dynamic_word_wrap in
+    let () = button "Show line number" show_line_number in
+    let () = button "Auto indentation" auto_indent in
+    let () = button "Auto completion" auto_complete in
+    let () = button "Show spaces" show_spaces in
+    let () = button "Show right margin" show_right_margin in
+    let () = button "Show progress bar" show_progress_bar in
+    let () = button "Insert spaces instead of tabs" spaces_instead_of_tabs in
+    let () = button "Highlight current line" highlight_current_line in
+    let () = button "Emacs/PG keybindings (μPG mode)" nanoPG in
+    let callback () = () in
     custom ~label box callback true
   in
 
@@ -600,177 +794,110 @@ let configure ?(apply=(fun () -> ())) () =
       (string_of_int current.window_width)
   in
 *)
-(*  let use_utf8_notation =
-    bool
-      ~f:(fun b ->
-	    current.use_utf8_notation <- b;
-	 )
-      "Use Unicode Notation: " current.use_utf8_notation
-  in
-*)
 (*
   let config_appearance = [show_toolbar; window_width; window_height] in
 *)
-  let global_auto_revert =
-    bool
-      ~f:(fun s -> current.global_auto_revert <- s)
-      "Enable global auto revert" current.global_auto_revert
-  in
+  let global_auto_revert = pbool "Enable global auto revert" global_auto_revert in
   let global_auto_revert_delay =
     string
-    ~f:(fun s -> current.global_auto_revert_delay <-
+    ~f:(fun s -> global_auto_revert_delay#set
 	  (try int_of_string s with _ -> 10000))
       "Global auto revert delay (ms)"
-      (string_of_int current.global_auto_revert_delay)
+      (string_of_int global_auto_revert_delay#get)
   in
 
-  let auto_save =
-    bool
-      ~f:(fun s -> current.auto_save <- s)
-      "Enable auto save" current.auto_save
-  in
+  let auto_save = pbool "Enable auto save" auto_save in
   let auto_save_delay =
     string
-    ~f:(fun s -> current.auto_save_delay <-
+    ~f:(fun s -> auto_save_delay#set
 	  (try int_of_string s with _ -> 10000))
       "Auto save delay (ms)"
-      (string_of_int current.auto_save_delay)
+      (string_of_int auto_save_delay#get)
   in
 
-  let stop_before =
-    bool
-      ~f:(fun s -> current.stop_before <- s)
-      "Stop interpreting before the current point" current.stop_before
-  in
+  let stop_before = pbool "Stop interpreting before the current point" 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 reset_on_tab_switch = pbool "Reset coqtop on tab switch" reset_on_tab_switch in
 
-  let vertical_tabs =
-    bool
-      ~f:(fun s -> current.vertical_tabs <- s; !refresh_tabs_hook ())
-      "Vertical tabs" current.vertical_tabs
-  in
+  let vertical_tabs = pbool "Vertical tabs" vertical_tabs in
 
-  let opposite_tabs =
-    bool
-      ~f:(fun s -> current.opposite_tabs <- s; !refresh_tabs_hook ())
-      "Tabs on opposite side" current.opposite_tabs
-  in
+  let opposite_tabs = pbool "Tabs on opposite side" opposite_tabs in
 
   let encodings =
     combo
       "File charset encoding "
-      ~f:(fun s -> current.encoding <- (inputenc_of_string s))
+      ~f:(fun s -> encoding#set (inputenc_of_string s))
       ~new_allowed: true
-      ("UTF-8"::"LOCALE":: match current.encoding with
+      ("UTF-8"::"LOCALE":: match encoding#get with
 	|Emanual s -> [s]
 	|_ -> []
       )
-      (string_of_inputenc current.encoding)
+      (string_of_inputenc encoding#get)
+  in
+
+  let line_ending =
+    combo
+      "EOL character"
+      ~f:(fun s -> line_ending#set (line_end_of_string s))
+      ~new_allowed:false
+      ["unix"; "windows"; "default"]
+      (line_end_to_string line_ending#get)
   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
+      ~f:source_style#set ~new_allowed:false
+      style_manager#style_scheme_ids source_style#get
   in
 
   let source_language =
-    let f s =
-      current.source_language <- s;
-      !refresh_language_hook ()
-    in
     combo "Language:"
-      ~f ~new_allowed:false
+      ~f:source_language#set ~new_allowed:false
       (List.filter
         (fun x -> Str.string_match (Str.regexp "^coq") x 0)
         lang_manager#language_ids)
-      current.source_language
+      source_language#get
   in
 
   let read_project =
     combo
       "Project file options are"
-      ~f:(fun s -> current.read_project <- project_behavior_of_string s)
+      ~f:(fun s -> read_project#set (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)
-  in
-  let project_file_name =
-    string "Default name for project file"
-      ~f:(fun s -> current.project_file_name <- s)
-      current.project_file_name
+      (string_of_project_behavior read_project#get)
   in
-  let help_string =
-    "restart to apply"
-  in
-  let the_valid_mod = str_to_mod_list current.modifiers_valid in
+  let project_file_name = pstring "Default name for project file" project_file_name in
   let modifier_for_tactics =
-    modifiers
-      ~allow:the_valid_mod
-      ~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)
+    pmodifiers "Modifiers for Tactics Menu" 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)
-      ~help:help_string
-      "Modifiers for Templates Menu"
-      (str_to_mod_list current.modifier_for_templates)
+    pmodifiers "Modifiers for Templates Menu" 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)
-      ~help:help_string
-      "Modifiers for Navigation Menu"
-      (str_to_mod_list current.modifier_for_navigation)
+    pmodifiers "Modifiers for Navigation Menu" 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)
-      ~help:help_string
-      "Modifiers for View Menu"
-      (str_to_mod_list current.modifier_for_display)
+    pmodifiers "Modifiers for View Menu" modifier_for_display
   in
-  let modifiers_valid =
-    modifiers
-      ~f:(fun l ->
-	current.modifiers_valid <- mod_list_to_str l)
-      "Allowed modifiers"
-      the_valid_mod
+  let modifier_for_queries =
+    pmodifiers "Modifiers for Queries Menu" modifier_for_queries
   in
-  let modifier_notice =
-    let b = GPack.hbox () in
-    let _lbl =
-      GMisc.label ~markup:"You need to <b>restart CoqIDE</b> after changing these settings"
-        ~packing:b#add () in
-    custom b (fun () -> ()) true
+  let modifiers_valid =
+    pmodifiers ~all:true "Allowed modifiers" modifiers_valid
   in
   let cmd_editor =
     let predefined = [ "emacs %s"; "vi %s"; "NOTEPAD %s" ] in
     combo
       ~help:"(%s for file name)"
       "External editor"
-      ~f:(fun s -> current.cmd_editor <- s)
+      ~f:cmd_editor#set
       ~new_allowed: true
-      (predefined@[if List.mem current.cmd_editor predefined then ""
-                   else current.cmd_editor])
-      current.cmd_editor
+      (predefined@[if List.mem cmd_editor#get predefined then ""
+                   else cmd_editor#get])
+      cmd_editor#get
   in
   let cmd_browse =
     let predefined = [
@@ -783,58 +910,82 @@ let configure ?(apply=(fun () -> ())) () =
     combo
       ~help:"(%s for url)"
       "Browser"
-      ~f:(fun s -> current.cmd_browse <- s)
+      ~f:cmd_browse#set
       ~new_allowed: true
-      (predefined@[if List.mem current.cmd_browse predefined then ""
-                   else current.cmd_browse])
-      current.cmd_browse
+      (predefined@[if List.mem cmd_browse#get predefined then ""
+                   else cmd_browse#get])
+      cmd_browse#get
   in
   let doc_url =
     let predefined = [
-      "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["html";"refman";""]);
+      "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["refman";"html"]);
       Coq_config.wwwrefman;
       use_default_doc_url
     ] in
     combo
       "Manual URL"
-      ~f:(fun s -> current.doc_url <- s)
+      ~f:doc_url#set
       ~new_allowed: true
-      (predefined@[if List.mem current.doc_url predefined then ""
-                   else current.doc_url])
-      current.doc_url in
+      (predefined@[if List.mem doc_url#get predefined then ""
+                   else doc_url#get])
+      doc_url#get in
   let library_url =
     let predefined = [
-      "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["html";"stdlib";""]);
+      "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["stdlib";"html"]);
       Coq_config.wwwstdlib
     ] in
     combo
       "Library URL"
-      ~f:(fun s -> current.library_url <- s)
+      ~f:(fun s -> library_url#set s)
       ~new_allowed: true
-      (predefined@[if List.mem current.library_url predefined then ""
-                   else current.library_url])
-      current.library_url
+      (predefined@[if List.mem library_url#get predefined then ""
+                   else library_url#get])
+      library_url#get
   in
   let automatic_tactics =
     strings
-      ~f:(fun l -> current.automatic_tactics <- l)
+      ~f:automatic_tactics#set
       ~add:(fun () -> ["<edit me>"])
       "Wizard tactics to try in order"
-      current.automatic_tactics
+      automatic_tactics#get
 
   in
 
-  let contextual_menus_on_goal =
-    bool
-      ~f:(fun s ->
-	    current.contextual_menus_on_goal <- s;
-	    !contextual_menus_on_goal_hook s)
-      "Contextual menus on goal" current.contextual_menus_on_goal
-  in
+  let contextual_menus_on_goal = pbool "Contextual menus on goal" contextual_menus_on_goal in
 
   let misc = [contextual_menus_on_goal;stop_before;reset_on_tab_switch;
               vertical_tabs;opposite_tabs] in
 
+  let add_user_query () =
+    let input_string l v =
+      match GToolbox.input_string ~title:l v with
+      | None -> ""
+      | Some s -> s
+    in
+    let q = input_string "User query" "Your query" in
+    let k = input_string "Shortcut key" "Shortcut (a single letter)" in
+    let q = CString.map (fun c -> if c = '$' then ' ' else c) q in
+    (* Anything that is not a simple letter will be ignored. *)
+    let k =
+      if Int.equal (CString.length k) 1 && Util.is_letter k.[0] then k
+      else "" in
+    let k = CString.uppercase k in
+      [q, k]
+  in
+
+  let user_queries =
+    list
+      ~f:user_queries#set
+      (* Disallow same query, key or empty query. *)
+      ~eq:(fun (q1, k1) (q2, k2) -> k1 = k2 || q1 = "" || q2 = "" || q1 = q2)
+      ~add:add_user_query
+      ~titles:["User query"; "Shortcut key"]
+      "User queries"
+      (fun (q, s) -> [q; s])
+      user_queries#get
+
+  in
+
 (* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!!
    (shame on Benjamin) *)
   let cmds =
@@ -842,11 +993,13 @@ let configure ?(apply=(fun () -> ())) () =
 	     [config_font]);
      Section("Colors", Some `SELECT_COLOR,
              [config_color; source_language; source_style]);
+     Section("Tags", Some `SELECT_COLOR,
+             [config_tags]);
      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*)
-	      encodings;
+	      encodings; line_ending;
 	     ]);
      Section("Project", Some (`STOCK "gtk-page-setup"),
 	     [project_file_name;read_project;
@@ -862,9 +1015,10 @@ let configure ?(apply=(fun () -> ())) () =
 	     [automatic_tactics]);
      Section("Shortcuts", Some `PREFERENCES,
 	     [modifiers_valid; modifier_for_tactics;
-	      modifier_for_templates; modifier_for_display; modifier_for_navigation; modifier_notice]);
+        modifier_for_templates; modifier_for_display; modifier_for_navigation;
+        modifier_for_queries; user_queries]);
      Section("Misc", Some `ADD,
-	     misc)]
+       misc)]
   in
 (*
   Format.printf "before edit: current.text_font = %s@." (Pango.Font.to_string current.text_font);
diff --git a/ide/preferences.mli b/ide/preferences.mli
index 4095eb66..801869d1 100644
--- a/ide/preferences.mli
+++ b/ide/preferences.mli
@@ -11,96 +11,101 @@ val style_manager : GSourceView2.source_style_scheme_manager
 
 type project_behavior = Ignore_args | Append_args | Subst_args
 type inputenc = Elocale | Eutf8 | Emanual of string
-
-type pref =
-    {
-      mutable cmd_coqtop : string option;
-      mutable cmd_coqc : string;
-      mutable cmd_make : string;
-      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;
-
-      mutable auto_save : bool;
-      mutable auto_save_delay : int;
-      mutable auto_save_name : string * string;
-
-      mutable read_project : project_behavior;
-      mutable project_file_name : string;
-      mutable project_path : string option;
-
-      mutable encoding : inputenc;
-
-      mutable automatic_tactics : string list;
-      mutable cmd_print : string;
-
-      mutable modifier_for_navigation : string;
-      mutable modifier_for_templates : string;
-      mutable modifier_for_tactics : string;
-      mutable modifier_for_display : string;
-      mutable modifiers_valid : string;
-
-      mutable cmd_browse : string;
-      mutable cmd_editor : string;
-
-      mutable text_font : Pango.font_description;
-
-      mutable doc_url : string;
-      mutable library_url : string;
-
-      mutable show_toolbar : bool;
-      mutable contextual_menus_on_goal : bool;
-      mutable window_width : int;
-      mutable window_height : int;
-      mutable query_window_width : int;
-      mutable query_window_height : int;
-(*
-      mutable use_utf8_notation : bool;
-*)
-      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 error_fg_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;
-
-    }
+type line_ending = [ `DEFAULT | `WINDOWS | `UNIX ]
+
+type tag = {
+  tag_fg_color : string option;
+  tag_bg_color : string option;
+  tag_bold : bool;
+  tag_italic : bool;
+  tag_underline : bool;
+}
+
+class type ['a] repr =
+object
+  method into : string list -> 'a option
+  method from : 'a -> string list
+end
+
+class ['a] preference_signals : changed:'a GUtil.signal ->
+object
+  inherit GUtil.ml_signals
+  method changed : callback:('a -> unit) -> GtkSignal.id
+end
+
+class ['a] preference : name:string list -> init:'a -> repr:'a repr ->
+object
+  method connect : 'a preference_signals
+  method get : 'a
+  method set : 'a -> unit
+  method reset : unit -> unit
+  method default : 'a
+end
+
+val list_tags : unit -> tag preference Util.String.Map.t
+
+val cmd_coqtop : string option preference
+val cmd_coqc : string preference
+val cmd_make : string preference
+val cmd_coqmakefile : string preference
+val cmd_coqdoc : string preference
+val source_language : string preference
+val source_style : string preference
+val global_auto_revert : bool preference
+val global_auto_revert_delay : int preference
+val auto_save : bool preference
+val auto_save_delay : int preference
+val auto_save_name : (string * string) preference
+val read_project : project_behavior preference
+val project_file_name : string preference
+val project_path : string option preference
+val encoding : inputenc preference
+val automatic_tactics : string list preference
+val cmd_print : string preference
+val modifier_for_navigation : string preference
+val modifier_for_templates : string preference
+val modifier_for_tactics : string preference
+val modifier_for_display : string preference
+val modifier_for_queries : string preference
+val modifiers_valid : string preference
+val cmd_browse : string preference
+val cmd_editor : string preference
+val text_font : string preference
+val doc_url : string preference
+val library_url : string preference
+val show_toolbar : bool preference
+val contextual_menus_on_goal : bool preference
+val window_width : int preference
+val window_height : int preference
+val auto_complete : bool preference
+val stop_before : bool preference
+val reset_on_tab_switch : bool preference
+val line_ending : line_ending preference
+val vertical_tabs : bool preference
+val opposite_tabs : bool preference
+val background_color : string preference
+val processing_color : string preference
+val processed_color : string preference
+val error_color : string preference
+val error_fg_color : string preference
+val dynamic_word_wrap : bool preference
+val show_line_number : bool preference
+val auto_indent : bool preference
+val show_spaces : bool preference
+val show_right_margin : bool preference
+val show_progress_bar : bool preference
+val spaces_instead_of_tabs : bool preference
+val tab_length : int preference
+val highlight_current_line : bool preference
+val nanoPG : bool preference
+val user_queries : (string * string) list preference
 
 val save_pref : unit -> unit
 val load_pref : unit -> unit
 
-val current : pref
-
 val configure : ?apply:(unit -> unit) -> unit -> unit
 
-(* Hooks *)
-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
+val stick : 'a preference ->
+  (#GObj.widget as 'obj) -> ('a -> unit) -> unit
 
 val use_default_doc_url : string
diff --git a/ide/project_file.ml4 b/ide/project_file.ml4
index 07ab5344..de0720e0 100644
--- a/ide/project_file.ml4
+++ b/ide/project_file.ml4
@@ -56,24 +56,24 @@ 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 ->
-    Pp.msg_warning (Pp.str "Please now use \"-arg -impredicative-set\" instead of \"-impredicative-set\" alone to be more uniform.");
+    Feedback.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 ->
-    Pp.msg_warning (Pp.(++) (Pp.str "Option -no-install is deprecated.") (Pp.(++) (Pp.spc ()) (Pp.str "Use \"-install none\" instead")));
+    Feedback.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 Pp.msg_warning (Pp.str "-install sets more than once.");
+    if install <> UnspecInstall then Feedback.msg_warning (Pp.str "-install sets more than once.");
     let install =
       match d with
 	| "user" -> UserInstall
 	| "none" -> NoInstall
 	| "global" -> TraditionalInstall
-	| _ -> Pp.msg_warning (Pp.(++) (Pp.str "invalid option '") (Pp.(++) (Pp.str d) (Pp.str "' passed to -install.")));
+	| _ -> Feedback.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 ->
-    Pp.msg_warning (Pp.app
+    Feedback.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.")
     );
@@ -86,7 +86,6 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts)
     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 ((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 (CUnix.correct_path p orig_dir,lp) :: l) r
   | ("-Q"|"-R"|"-I"|"-custom"|"-extra"|"-extra-phony") :: _ ->
@@ -95,7 +94,7 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts)
     let file = CUnix.remove_path_dot (CUnix.correct_path file orig_dir) in
     let () = match project_file with
       | None -> ()
-      | Some _ -> Pp.msg_warning (Pp.str
+      | Some _ -> Feedback.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
@@ -110,7 +109,7 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts)
 	let () = match makefile with
 	  |None -> ()
 	  |Some f ->
-	     Pp.msg_warning (Pp.(++) (Pp.str "Only one output file is genererated. ") (Pp.(++) (Pp.str f) (Pp.str " will not be.")))
+	     Feedback.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 ->
@@ -139,48 +138,44 @@ let rec post_canonize f =
   else f
 
 (* 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 ((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,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,(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,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,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,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)
-  | 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,(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 split_arguments args =
+  List.fold_right
+    (fun a ((v,(mli,ml4,ml,mllib,mlpack as m),o,s as t),
+            (ml_inc,q_inc,r_inc as i),(args,defs as d)) ->
+     match a with
+     | V n ->
+        ((CUnix.remove_path_dot n::v,m,o,s),i,d)
+     | ML n ->
+        ((v,(mli,ml4,CUnix.remove_path_dot n::ml,mllib,mlpack),o,s),i,d)
+     | MLI n ->
+        ((v,(CUnix.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d)
+     | ML4 n ->
+        ((v,(mli,CUnix.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d)
+     | MLLIB n ->
+        ((v,(mli,ml4,ml,CUnix.remove_path_dot n::mllib,mlpack),o,s),i,d)
+     | MLPACK n ->
+        ((v,(mli,ml4,ml,mllib,CUnix.remove_path_dot n::mlpack),o,s),i,d)
+     | Special (n,dep,is_phony,c) ->
+        ((v,m,(n,dep,is_phony,c)::o,s),i,d)
+     | Subdir n ->
+        ((v,m,o,n::s),i,d)
+     | MLInclude p ->
+        let ml_new = (CUnix.remove_path_dot (post_canonize p),
+                      CUnix.canonical_path_name p) in
+        (t,(ml_new::ml_inc,q_inc,r_inc),d)
+     | Include (p,l) ->
+        let q_new = (CUnix.remove_path_dot (post_canonize p),l,
+		     CUnix.canonical_path_name p) in
+        (t,(ml_inc,q_new::q_inc,r_inc),d)
+     | RInclude (p,l) ->
+        let r_new = (CUnix.remove_path_dot (post_canonize p),l,
+		     CUnix.canonical_path_name p) in
+        (t,(ml_inc,q_inc,r_new::r_inc),d)
+     | Def (v,def) ->
+        (t,i,(args,(v,def)::defs))
+     | Arg a ->
+        (t,i,(a::args,defs)))
+    args (([],([],[],[],[],[]),[],[]),([],[],[]),([],[]))
 
 let read_project_file f =
   split_arguments
diff --git a/printing/richprinter.ml b/ide/richprinter.ml
index d95e1907..5f39f36e 100644
--- a/printing/richprinter.ml
+++ b/ide/richprinter.ml
@@ -22,4 +22,3 @@ let make_richpp pr ast =
 
 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/ide/richprinter.mli
index 261d22c4..c9e84e3e 100644
--- a/printing/richprinter.mli
+++ b/ide/richprinter.mli
@@ -34,6 +34,3 @@ 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/ide/sentence.ml b/ide/sentence.ml
index 0f6c1168..e332682d 100644
--- a/ide/sentence.ml
+++ b/ide/sentence.ml
@@ -16,6 +16,7 @@
 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.warning;
   buffer#remove_tag ~start ~stop Tags.Script.error_bg;
   let slice = buffer#get_text ~start ~stop () in
   let apply_tag off tag =
@@ -63,13 +64,13 @@ let grab_sentence_start (iter:GText.iter) soi =
 
 (** Search forward the first character immediately after a sentence end *)
 
-let rec grab_sentence_stop (start:GText.iter) =
+let 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 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
 
diff --git a/lib/serialize.ml b/ide/serialize.ml
index 79a79dd4..7b568501 100644
--- a/lib/serialize.ml
+++ b/ide/serialize.ml
@@ -8,7 +8,7 @@
 
 open Xml_datatype
 
-exception Marshal_error
+exception Marshal_error of string * xml
 
 (** Utility functions *)
 
@@ -19,30 +19,31 @@ let rec get_attr attr = function
 
 let massoc x l =
   try get_attr x l
-  with Not_found -> raise Marshal_error
+  with Not_found -> raise (Marshal_error("attribute " ^ x,PCData "not there"))
 
 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
+  | x -> raise (Marshal_error (t,x))
 
 let singleton = function
   | [x] -> x
-  | _ -> raise Marshal_error
+  | l -> raise (Marshal_error
+      ("singleton",PCData ("list of length " ^ string_of_int (List.length l))))
 
 let raw_string = function
   | [] -> ""
   | [PCData s] -> s
-  | _ -> raise Marshal_error
+  | x::_ -> raise (Marshal_error("raw string",x))
 
 (** Base types *)
 
 let of_unit () = Element ("unit", [], [])
 let to_unit : xml -> unit = function
   | Element ("unit", [], []) -> ()
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error ("unit",x))
 
 let of_bool (b : bool) : xml =
   if b then constructor "bool" "true" []
@@ -50,13 +51,13 @@ let of_bool (b : bool) : xml =
 let to_bool : xml -> bool = do_match "bool" (fun s _ -> match s with
   | "true" -> true
   | "false" -> false
-  | _ -> raise Marshal_error)
+  | x -> raise (Marshal_error("bool",PCData x)))
 
 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
+  | x -> raise (Marshal_error("list",x))
 
 let of_option (f : 'a -> xml) : 'a option -> xml = function
   | None -> Element ("option", ["val", "none"], [])
@@ -64,24 +65,24 @@ let of_option (f : 'a -> xml) : 'a option -> xml = function
 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
+  | x -> raise (Marshal_error("option",x))
 
 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
+  | x -> raise (Marshal_error("string",x))
 
 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
+    (try int_of_string s with Failure _ -> raise(Marshal_error("int",PCData s)))
+  | x -> raise (Marshal_error("int",x))
 
 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
+  | x -> raise (Marshal_error("pair",x))
 
 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])
@@ -89,7 +90,7 @@ let of_union (f : 'a -> xml) (g : 'b -> xml) : ('a,'b) CSig.union -> xml = funct
 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
+  | x -> raise (Marshal_error("union",x))
 
 (** More elaborate types *)
 
@@ -99,7 +100,7 @@ let to_edit_id = function
       let id = int_of_string i in
       assert (id <= 0 );
       id
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error("edit_id",x))
 
 let of_loc loc =
   let start, stop = Loc.unloc loc in
@@ -107,10 +108,14 @@ let of_loc loc =
 let to_loc xml =
   match xml with
   | Element ("loc", l,[]) ->
+      let start = massoc "start" l in
+      let stop = massoc "stop" l in
       (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
+      with Not_found | Invalid_argument _ -> raise (Marshal_error("loc",PCData(start^":"^stop))))
+  | x -> raise (Marshal_error("loc",x))
 
+let of_xml x = Element ("xml", [], [x])
+let to_xml xml = match xml with
+| Element ("xml", [], [x]) -> x
+| x -> raise (Marshal_error("xml",x))
diff --git a/lib/serialize.mli b/ide/serialize.mli
index 2a8e5316..bf9e184e 100644
--- a/lib/serialize.mli
+++ b/ide/serialize.mli
@@ -8,7 +8,7 @@
 
 open Xml_datatype
 
-exception Marshal_error
+exception Marshal_error of string * xml
 
 val massoc: string -> (string * string) list -> string
 val constructor: string -> string -> xml list -> xml
@@ -35,3 +35,5 @@ val of_edit_id: int -> xml
 val to_edit_id: xml -> int
 val of_loc : Loc.t -> xml
 val to_loc : xml -> Loc.t
+val of_xml : xml -> xml
+val to_xml : xml -> xml
diff --git a/ide/session.ml b/ide/session.ml
index 34c533b8..fc6340d2 100644
--- a/ide/session.ml
+++ b/ide/session.ml
@@ -8,8 +8,6 @@
 
 open Preferences
 
-let prefs = Preferences.current
-
 (** A session is a script buffer + proof + messages,
     interacting with a coqtop, and a few other elements around *)
 
@@ -18,7 +16,7 @@ class type ['a] page =
     inherit GObj.widget
     method update : 'a -> unit
     method on_update : callback:('a -> unit) -> unit
-    method refresh_color : unit -> unit
+    method data : 'a
   end
 
 class type control =
@@ -50,8 +48,8 @@ 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)
+    ?language:(lang_manager#language source_language#get)
+    ?style_scheme:(style_manager#style_scheme source_style#get)
     ()
   in
   let _ = buffer#create_mark ~name:"start_of_input" buffer#start_iter in
@@ -110,10 +108,10 @@ let set_buffer_handlers
     let id = ref 0 in
     fun () -> incr id; !id in
   let running_action = ref None in
-  let cancel_signal reason =
+  let cancel_signal ?(stop_emit=true) reason =
     Minilib.log ("user_action cancelled: "^reason);
     action_was_cancelled := true;
-    GtkSignal.stop_emit () in
+    if stop_emit then GtkSignal.stop_emit () in
   let del_mark () =
     try buffer#delete_mark (`NAME "target")
     with GText.No_such_mark _ -> () in
@@ -126,7 +124,7 @@ let set_buffer_handlers
       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
+        | _ -> cancel_signal ~stop_emit:false "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
@@ -197,12 +195,8 @@ let set_buffer_handlers
          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;
+	List.iter (fun tag -> buffer#remove_tag tag ~start ~stop)
+		  Tags.Script.ephemere;
         Sentence.tag_on_insert buffer
       end;
     end in
@@ -254,10 +248,9 @@ let make_table_widget ?sort cd cb =
       ~model:store ~packing:frame#add () in
   let () = data#set_headers_visible true in
   let () = data#set_headers_clickable true in
-  let refresh () =
-    let clr = Tags.color_of_string current.background_color in
-    data#misc#modify_base [`NORMAL, `COLOR clr]
-  in
+  let refresh clr = data#misc#modify_base [`NORMAL, `NAME clr] in
+  let _ = background_color#connect#changed refresh in
+  let _ = data#misc#connect#realize (fun () -> refresh background_color#get) in
   let mk_rend c = GTree.cell_renderer_text [], ["text",c] in
   let cols =
     List.map2 (fun (_,c) (_,n,v) ->
@@ -285,10 +278,10 @@ let make_table_widget ?sort cd cb =
     data#connect#row_activated ~callback:(fun tp vc -> cb columns store tp vc)
   );
   let () = match sort with None -> () | Some (i, t) -> store#set_sort_column_id i t in
-  frame, (fun f -> f columns store), refresh
+  frame, (fun f -> f columns store)
 
 let create_errpage (script : Wg_ScriptView.script_view) : errpage =
-  let table, access, refresh =
+  let table, access =
     make_table_widget ~sort:(0, `ASCENDING)
       [`Int,"Line",true; `String,"Error message",true]
       (fun columns store tp vc ->
@@ -320,11 +313,11 @@ let create_errpage (script : Wg_ScriptView.script_view) : errpage =
           errs
       end
     method on_update ~callback:cb = callback := cb
-    method refresh_color () = refresh ()
+    method data = !last_update
   end
 
 let create_jobpage coqtop coqops : jobpage =
-  let table, access, refresh =
+  let table, access =
     make_table_widget ~sort:(0, `ASCENDING)
       [`String,"Worker",true; `String,"Job name",true]
       (fun columns store tp vc ->
@@ -360,7 +353,7 @@ let create_jobpage coqtop coqops : jobpage =
           jobs
       end
     method on_update ~callback:cb = callback := cb
-    method refresh_color () = refresh ()
+    method data = !last_update
   end
 
 let create_proof () =
diff --git a/ide/session.mli b/ide/session.mli
index 0881e403..028a1f9d 100644
--- a/ide/session.mli
+++ b/ide/session.mli
@@ -14,7 +14,7 @@ class type ['a] page =
     inherit GObj.widget
     method update : 'a -> unit
     method on_update : callback:('a -> unit) -> unit
-    method refresh_color : unit -> unit
+    method data : 'a
   end
 
 class type control =
diff --git a/ide/tags.ml b/ide/tags.ml
index 0e4ab96d..e4510e7a 100644
--- a/ide/tags.ml
+++ b/ide/tags.ml
@@ -13,28 +13,16 @@ let make_tag (tt:GText.tag_table) ~name prop =
   tt#add new_tag#as_tag;
   new_tag
 
-(* These work fine for colorblind people too *)
-let default_processed_color = "light green"
-let default_processing_color = "light blue"
-let default_error_color = "#FFCCCC"
-let default_error_fg_color = "red"
-let default_color = "cornsilk"
-
-let processed_color = ref default_processed_color
-let processing_color = ref default_processing_color
-let error_color = ref default_error_color
-let error_fg_color = ref default_error_fg_color
-
 module Script =
 struct
   let table = GText.tag_table ()
   let comment = make_tag table ~name:"comment" []
-  let error = make_tag table ~name:"error" [`UNDERLINE `SINGLE ; `FOREGROUND !error_fg_color]
-  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 error = make_tag table ~name:"error" [`UNDERLINE `SINGLE]
+  let warning = make_tag table ~name:"warning" [`UNDERLINE `SINGLE; `FOREGROUND "blue"]
+  let error_bg = make_tag table ~name:"error_bg" []
+  let to_process = make_tag table ~name:"to_process" []
+  let processed = make_tag table ~name:"processed" []
   let incomplete = make_tag table ~name:"incomplete" [
-          `BACKGROUND !processing_color;
           `BACKGROUND_STIPPLE_SET true;
   ]
   let unjustified = make_tag table ~name:"unjustified" [`BACKGROUND "gold"]
@@ -42,9 +30,11 @@ struct
   let sentence = make_tag table ~name:"sentence" []
   let tooltip = make_tag table ~name:"tooltip" [] (* debug:`BACKGROUND "blue" *)
 
+  let ephemere =
+    [error; warning; error_bg; tooltip; processed; to_process; incomplete; unjustified]
+
   let all =
-    [comment; error; error_bg; to_process; processed; incomplete; unjustified;
-     found; sentence; tooltip]
+    comment :: found :: sentence :: ephemere
 
   let edit_zone =
     let t = make_tag table ~name:"edit_zone" [`UNDERLINE `SINGLE] in
@@ -56,7 +46,7 @@ end
 module Proof =
 struct
   let table = GText.tag_table ()
-  let highlight = make_tag table ~name:"highlight" [`BACKGROUND !processed_color]
+  let highlight = make_tag table ~name:"highlight" []
   let hypothesis = make_tag table ~name:"hypothesis" []
   let goal = make_tag table ~name:"goal" []
 end
@@ -77,34 +67,3 @@ let string_of_color clr =
 let color_of_string s =
   let colormap = Gdk.Color.get_system_colormap () in
   Gdk.Color.alloc ~colormap (`NAME s)
-
-let get_processed_color () = color_of_string !processed_color
-
-let set_processed_color clr =
-  let s = string_of_color clr in
-  processed_color := s;
-  Script.processed#set_property (`BACKGROUND s);
-  Proof.highlight#set_property (`BACKGROUND s)
-
-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)
-
-let get_error_fg_color () = color_of_string !error_fg_color
-
-let set_error_fg_color clr =
-  let s = string_of_color clr in
-  error_fg_color := s;
-  Script.error#set_property (`FOREGROUND s)
-
diff --git a/ide/tags.mli b/ide/tags.mli
index 00583f1b..02e15a5a 100644
--- a/ide/tags.mli
+++ b/ide/tags.mli
@@ -11,6 +11,7 @@ sig
   val table : GText.tag_table
   val comment : GText.tag
   val error : GText.tag
+  val warning : GText.tag
   val error_bg : GText.tag
   val to_process : GText.tag
   val processed : GText.tag
@@ -20,6 +21,7 @@ sig
   val sentence : GText.tag
   val tooltip : GText.tag
   val edit_zone : GText.tag (* for debugging *)
+  val ephemere : GText.tag list
   val all : GText.tag list
 end
 
@@ -41,22 +43,3 @@ end
 
 val string_of_color : Gdk.color -> string
 val color_of_string : string -> Gdk.color
-
-val get_processed_color : unit -> Gdk.color
-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
-
-val get_error_fg_color : unit -> Gdk.color
-val set_error_fg_color : Gdk.color -> unit
-
-val default_processed_color : string
-val default_processing_color : string
-val default_error_color : string
-val default_error_fg_color : string
-val default_color : string
-
diff --git a/stm/texmacspp.ml b/ide/texmacspp.ml
index 85cb4570..680da7f5 100644
--- a/stm/texmacspp.ml
+++ b/ide/texmacspp.ml
@@ -20,9 +20,6 @@ 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)
@@ -191,7 +188,9 @@ match sm with
       | LeftA -> ["associativity", "left"]
       end
   | SetEntryType (s, _) -> ["entrytype", s]
-  | SetOnlyParsing v -> ["compat", Flags.pr_version v]
+  | SetOnlyPrinting -> ["onlyprinting", ""]
+  | SetOnlyParsing -> ["onlyparsing", ""]
+  | SetCompatVersion v -> ["compat", Flags.pr_version v]
   | SetFormat (system, (loc, s)) ->
       let start, stop = unlock loc in
       ["format-"^system, s; "begin", start; "end", stop]
@@ -240,6 +239,8 @@ and pp_local_binder lb = (* don't know what it is for now *)
       let ppl =
         List.map (fun (loc, nam) -> (xmlCst (string_of_name nam) loc)) namll in
       xmlTyped (ppl @ [pp_expr ce])
+  | LocalPattern _ ->
+      assert false
 and pp_local_decl_expr lde = (* don't know what it is for now *)
   match lde with
   | AssumExpr (_, ce) -> pp_expr ce
@@ -307,7 +308,13 @@ and pp_cases_pattern_expr cpe =
       xmlApply loc
         (xmlOperator "alias" ~attr:["name", string_of_id id] loc ::
           [pp_cases_pattern_expr cpe])
-  | CPatCstr (loc, ref, cpel1, cpel2) ->
+  | CPatCstr (loc, ref, None, cpel2) ->
+      xmlApply loc
+        (xmlOperator "reference"
+           ~attr:["name", Libnames.string_of_reference ref] loc ::
+         [Element ("impargs", [], []);
+          Element ("args", [], (List.map pp_cases_pattern_expr cpel2))])
+  | CPatCstr (loc, ref, Some cpel1, cpel2) ->
       xmlApply loc
         (xmlOperator "reference"
            ~attr:["name", Libnames.string_of_reference ref] loc ::
@@ -347,7 +354,8 @@ and pp_cases_pattern_expr cpe =
       xmlApply loc
         (xmlOperator "delimiter" ~attr:["name", delim] loc ::
           [pp_cases_pattern_expr cpe])
-and pp_case_expr (e, (name, pat)) =
+  | CPatCast _ -> assert false
+and pp_case_expr (e, name, pat) =
   match name, pat with
   | None, None -> xmlScrutinee [pp_expr e]
   | Some (loc, name), None ->
@@ -460,7 +468,7 @@ and pp_expr ?(attr=[]) e =
           (return @
            [Element ("scrutinees", [], List.map pp_case_expr cel)] @
            [pp_branch_expr_list bel]))
-  | CRecord (_, _, _) -> assert false
+  | CRecord (_, _) -> assert false
   | CLetIn (loc, (varloc, var), value, body) ->
       xmlApply loc
         (xmlOperator "let" loc ::
@@ -487,12 +495,12 @@ let rec tmpp v loc =
   (* Control *)
   | VernacLoad (verbose,f) ->
       xmlWithLoc loc "load" ["verbose",string_of_bool verbose;"file",f] []
-  | VernacTime l ->
+  | VernacTime (loc,e) ->
       xmlApply loc (Element("time",[],[]) ::
-                    List.map (fun(loc,e) ->tmpp e loc) l)
-  | VernacRedirect (s, l) ->
+                    [tmpp e loc])
+  | VernacRedirect (s, (loc,e)) ->
       xmlApply loc (Element("redirect",["path", s],[]) ::
-                      List.map (fun(loc,e) ->tmpp e loc) l)
+                    [tmpp e loc])
   | VernacTimeout (s,e) ->
       xmlApply loc (Element("timeout",["val",string_of_int s],[]) ::
                     [tmpp e loc])
@@ -500,9 +508,6 @@ let rec tmpp v 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
@@ -513,13 +518,6 @@ let rec tmpp v loc =
       xmlScope loc "delimit" name ~attr:["delimiter",tag] []
   | VernacDelimiters (name,None) ->
       xmlScope loc "undelimit" name ~attr:[] []
-  | 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 =
@@ -535,6 +533,7 @@ let rec tmpp v loc =
         | Some scope -> ["scope", scope]
         | None -> [] in
       xmlNotation (sc_attr @ attrs) name loc [pp_expr ce]
+  | VernacBindScope _ as x -> xmlTODO loc x
   | VernacNotationAddFormat _ as x -> xmlTODO loc x
   | VernacUniverse _
   | VernacConstraint _
@@ -668,7 +667,7 @@ let rec tmpp v loc =
 
   (* Solving *)
 
-  | (VernacSolve _ | VernacSolveExistential _) as x ->
+  | (VernacSolveExistential _) as x ->
       xmlLtac loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))]
 
   (* Auxiliary file and library management *)
@@ -694,7 +693,6 @@ let rec tmpp v loc =
   | 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
@@ -711,6 +709,7 @@ let rec tmpp v loc =
   | VernacSetStrategy _ as x -> xmlTODO loc x
   | VernacUnsetOption _ as x -> xmlTODO loc x
   | VernacSetOption _ as x -> xmlTODO loc x
+  | VernacSetAppendOption _ as x -> xmlTODO loc x
   | VernacAddOption _ as x -> xmlTODO loc x
   | VernacRemoveOption _ as x -> xmlTODO loc x
   | VernacMemOption _ as x -> xmlTODO loc x
@@ -724,7 +723,6 @@ let rec tmpp v loc =
   | 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
diff --git a/stm/texmacspp.mli b/ide/texmacspp.mli
index 858847fb..858847fb 100644
--- a/stm/texmacspp.mli
+++ b/ide/texmacspp.mli
diff --git a/ide/utils/configwin_keys.ml b/ide/utils/configwin_keys.ml
index 9f44e5c6..e9b19da6 100644
--- a/ide/utils/configwin_keys.ml
+++ b/ide/utils/configwin_keys.ml
@@ -154,7 +154,7 @@ let xk_KP_9			= 0xFFB9
 
 
 (*
- * Auxilliary Functions; note the duplicate definitions for left and right
+ * Auxiliary Functions; note the duplicate definitions for left and right
  * function keys;  Sun keyboards and a few other manufactures have such
  * function key groups on the left and/or right sides of the keyboard.
  * We've not found a keyboard with more than 35 function keys total.
diff --git a/ide/utils/okey.ml b/ide/utils/okey.ml
index 580f1fbc..8f6cb382 100644
--- a/ide/utils/okey.ml
+++ b/ide/utils/okey.ml
@@ -52,33 +52,6 @@ let int_of_modifier = function
   | `RELEASE -> 1 lsl 30
   | `SUPER -> 1 lsl 21
 
-let print_modifier l =
-  List.iter
-    (fun m ->
-      print_string
-	(((function
-	    `SHIFT -> "SHIFT"
-	  | `LOCK -> "LOCK"
-	  | `CONTROL -> "CONTROL"
-	  | `MOD1 -> "MOD1"
-	  | `MOD2 -> "MOD2"
-	  | `MOD3 -> "MOD3"
-	  | `MOD4 -> "MOD4"
-	  | `MOD5 -> "MOD5"
-	  | `BUTTON1 -> "B1"
-	  | `BUTTON2 -> "B2"
-	  | `BUTTON3 -> "B3"
-	  | `BUTTON4 -> "B4"
-	  | `BUTTON5 -> "B5"
-          | `HYPER -> "HYPER"                                                                                                     
-          | `META -> "META"                                                                                                       
-          | `RELEASE -> ""                                                                                                        
-          | `SUPER -> "SUPER")
-	    m)^" ")
-    )
-    l;
-  print_newline ()
-
 let int_of_modifiers l =
   List.fold_left (fun acc -> fun m -> acc + (int_of_modifier m)) 0 l
 
diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml
index a3e5ea3f..946aaf01 100644
--- a/ide/wg_Command.ml
+++ b/ide/wg_Command.ml
@@ -85,9 +85,11 @@ object(self)
 	~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];
+    let cb clr = result#misc#modify_base [`NORMAL, `NAME clr] in
+    let _ = background_color#connect#changed cb in
+    let _ = result#misc#connect#realize (fun () -> cb background_color#get) in
+    let cb ft = result#misc#modify_font (Pango.Font.from_string ft) in
+    stick text_font result cb;
     result#misc#set_can_focus true; (* false causes problems for selection *)
     result#set_editable false;
     let callback () =
@@ -98,11 +100,14 @@ object(self)
         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 log level message =
+        Ideutils.insert_xml result#buffer message;
+        result#buffer#insert "\n";
+      in
       let process =
 	Coq.bind (Coq.query ~logger:log (phrase,Stateid.dummy)) (function
           | Interface.Fail (_,l,str) ->
-            result#buffer#insert str;
+            Ideutils.insert_xml result#buffer str;
             notebook#set_page ~tab_label:(new_tab_lbl "Error") frame#coerce;
 	    Coq.return ()
           | Interface.Good res ->
@@ -144,13 +149,9 @@ object(self)
 
   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
+  method private refresh_color clr =
+    let clr = Tags.color_of_string clr in
     let iter (_,view,_) = view#misc#modify_base [`NORMAL, `COLOR clr] in
     List.iter iter views
 
@@ -158,6 +159,8 @@ object(self)
     self#new_page_maker;
     self#new_query_aux ~grab_now:false ();
     frame#misc#hide ();
+    let _ = background_color#connect#changed self#refresh_color in
+    self#refresh_color background_color#get;
     ignore(notebook#event#connect#key_press ~callback:(fun ev ->
       if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then (self#hide; true)
       else false
diff --git a/ide/wg_Command.mli b/ide/wg_Command.mli
index 97f96f45..fa50ba5f 100644
--- a/ide/wg_Command.mli
+++ b/ide/wg_Command.mli
@@ -10,8 +10,6 @@ class command_window : string -> Coq.coqtop ->
   object
     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
diff --git a/ide/wg_Completion.ml b/ide/wg_Completion.ml
index 3c228998..aeae3e1f 100644
--- a/ide/wg_Completion.ml
+++ b/ide/wg_Completion.ml
@@ -86,7 +86,7 @@ let signals = [
   end_s#disconnect;
 ] in
 object (self : 'a)
-  inherit GUtil.ml_signals signals as super
+  inherit GUtil.ml_signals signals
   method start_completion = start_s#connect ~after
   method update_completion = update_s#connect ~after
   method end_completion = end_s#connect ~after
@@ -258,7 +258,7 @@ object (self)
 
   method private refresh_style () =
     let (renderer, _) = renderer in
-    let font = Preferences.current.Preferences.text_font in
+    let font = Pango.Font.from_string Preferences.text_font#get in
     renderer#set_properties [`FONT_DESC font; `XPAD 10]
 
   method private coordinates pos =
diff --git a/ide/wg_Find.ml b/ide/wg_Find.ml
index 47901237..3d847ddc 100644
--- a/ide/wg_Find.ml
+++ b/ide/wg_Find.ml
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-type mode = [ `FIND | `REPLACE ]
-
 let b2c = Ideutils.byte_offset_to_char_offset
 
 class finder name (view : GText.view) =
diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml
index f2b8336c..0330b8ef 100644
--- a/ide/wg_MessageView.ml
+++ b/ide/wg_MessageView.ml
@@ -6,11 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Preferences
+
 class type message_view_signals =
 object
   inherit GObj.misc_signals
   inherit GUtil.add_ml_signals
-  method pushed : callback:(Pp.message_level -> string -> unit) -> GtkSignal.id
+  method pushed : callback:Ideutils.logger -> GtkSignal.id
 end
 
 class message_view_signals_impl obj (pushed : 'a GUtil.signal) : message_view_signals =
@@ -26,14 +28,13 @@ class type message_view =
     inherit GObj.widget
     method connect : message_view_signals
     method clear : unit
-    method add : string -> unit
-    method set : string -> unit
-    method push : Pp.message_level -> string -> unit
+    method add : Richpp.richpp -> unit
+    method add_string : string -> unit
+    method set : Richpp.richpp -> unit
+    method push : Ideutils.logger
       (** 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
-    method refresh_color : unit -> unit
   end
 
 let message_view () : message_view =
@@ -42,6 +43,7 @@ let message_view () : message_view =
     ~tag_table:Tags.Message.table ()
   in
   let text_buffer = new GText.buffer buffer#as_buffer in
+  let mark = buffer#create_mark ~left_gravity:false buffer#start_iter in
   let box = GPack.vbox () in
   let scroll = GBin.scrolled_window
     ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:(box#pack ~expand:true) () in
@@ -53,6 +55,12 @@ let message_view () : message_view =
   let default_clipboard = GData.clipboard Gdk.Atom.primary in
   let _ = buffer#add_selection_clipboard default_clipboard in
   let () = view#set_left_margin 2 in
+  view#misc#show ();
+  let cb clr = view#misc#modify_base [`NORMAL, `NAME clr] in
+  let _ = background_color#connect#changed cb in
+  let _ = view#misc#connect#realize (fun () -> cb background_color#get) in
+  let cb ft = view#misc#modify_font (Pango.Font.from_string ft) in
+  stick text_font view cb;
   object (self)
     inherit GObj.widget box#as_widget
 
@@ -62,31 +70,33 @@ let message_view () : message_view =
       new message_view_signals_impl box#as_widget push
 
     method clear =
-      buffer#set_text ""
+      buffer#set_text "";
+      buffer#move_mark (`MARK mark) ~where:buffer#start_iter
 
     method push level msg =
       let tags = match level with
-      | Pp.Error -> [Tags.Message.error]
-      | Pp.Warning -> [Tags.Message.warning]
+      | Feedback.Error -> [Tags.Message.error]
+      | Feedback.Warning -> [Tags.Message.warning]
       | _ -> []
       in
-      if msg <> "" then begin
-        buffer#insert ~tags msg;
-        buffer#insert ~tags "\n";
+      let rec non_empty = function
+      | Xml_datatype.PCData "" -> false
+      | Xml_datatype.PCData _ -> true
+      | Xml_datatype.Element (_, _, children) -> List.exists non_empty children
+      in
+      if non_empty (Richpp.repr msg) then begin
+        let mark = `MARK mark in
+        Ideutils.insert_xml ~mark buffer ~tags msg;
+        buffer#insert ~iter:(buffer#get_iter_at_mark mark) "\n";
         push#call (level, msg)
       end
 
-    method add msg = self#push Pp.Notice msg
+    method add msg = self#push Feedback.Notice msg
+
+    method add_string s = self#add (Richpp.richpp_of_string s)
 
     method set msg = self#clear; self#add msg
 
     method buffer = text_buffer
 
-    method modify_font fd = view#misc#modify_font fd
-
-    method refresh_color () =
-      let open Preferences in
-      let clr = Tags.color_of_string current.background_color in
-      view#misc#modify_base [`NORMAL, `COLOR clr]
-
   end
diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli
index ebcb2163..2d34533d 100644
--- a/ide/wg_MessageView.mli
+++ b/ide/wg_MessageView.mli
@@ -10,7 +10,7 @@ class type message_view_signals =
 object
   inherit GObj.misc_signals
   inherit GUtil.add_ml_signals
-  method pushed : callback:(Pp.message_level -> string -> unit) -> GtkSignal.id
+  method pushed : callback:Ideutils.logger -> GtkSignal.id
 end
 
 class type message_view =
@@ -18,14 +18,13 @@ class type message_view =
     inherit GObj.widget
     method connect : message_view_signals
     method clear : unit
-    method add : string -> unit
-    method set : string -> unit
-    method push : Pp.message_level -> string -> unit
+    method add : Richpp.richpp -> unit
+    method add_string : string -> unit
+    method set : Richpp.richpp -> unit
+    method push : Ideutils.logger
       (** 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
-    method refresh_color : unit -> unit
   end
 
 val message_view : unit -> message_view
diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml
index 0007203e..47c86045 100644
--- a/ide/wg_ProofView.ml
+++ b/ide/wg_ProofView.ml
@@ -7,6 +7,8 @@
 (************************************************************************)
 
 open Util
+open Preferences
+open Ideutils
 
 class type proof_view =
   object
@@ -82,26 +84,28 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with
           let () = hook_tag_cb tag hint sel_cb on_hover in
           [tag], hints
         in
-        let () = proof#buffer#insert ~tags (hyp ^ "\n") in
+        let () = insert_xml ~tags proof#buffer hyp in
+        proof#buffer#insert "\n";
         insert_hyp rem_hints hs
       in
       let () = proof#buffer#insert head_str in
       let () = insert_hyp hyps_hints hyps in
       let () =
-        let tags = Tags.Proof.goal :: if goal_hints <> [] then
+        let _ = if goal_hints <> [] then
           let tag = proof#buffer#create_tag [] in
           let () = hook_tag_cb tag goal_hints sel_cb on_hover in
           [tag]
           else []
         in
         proof#buffer#insert (goal_str 1 goals_cnt);
-        proof#buffer#insert ~tags cur_goal;
+        insert_xml proof#buffer cur_goal;
         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")
+        insert_xml proof#buffer g;
+        proof#buffer#insert "\n"
       in
       let () = Util.List.fold_left_i fold_goal 2 () rem_goals in
 
@@ -110,17 +114,6 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with
                          (Some Tags.Proof.goal)));
       ignore(proof#scroll_to_mark ~use_align:true ~yalign:0.95 `INSERT)
 
-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";
-      List.iter
-        (fun hyp -> proof#buffer#insert (hyp^"\n"))
-        hyps;
-      proof#buffer#insert "______________________________________\n";
-      proof#buffer#insert ("thesis := \n "^cur_goal^"\n");
-      ignore (proof#scroll_to_iter (proof#buffer#get_iter_at_mark `INSERT))
-
 let rec flatten = function
 | [] -> []
 | (lg, rg) :: l ->
@@ -151,8 +144,8 @@ let display mode (view : #GText.view_skel) goals hints evars =
       (* The proof is finished, with the exception of given up goals. *)
       view#buffer#insert "No more subgoals, but there are some goals you gave up:\n\n";
       let iter goal =
-        let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in
-        view#buffer#insert msg
+        insert_xml view#buffer goal.Interface.goal_ccl;
+        view#buffer#insert "\n"
       in
       List.iter iter given_up_goals;
       view#buffer#insert "\nYou need to go back and solve them."
@@ -160,8 +153,8 @@ let display mode (view : #GText.view_skel) goals hints evars =
       (* 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
+        insert_xml view#buffer goal.Interface.goal_ccl;
+        view#buffer#insert "\n"
       in
       List.iter iter shelved_goals
     | _, _, _, _ ->
@@ -173,8 +166,8 @@ let display mode (view : #GText.view_skel) goals hints evars =
       view#buffer#insert "This subproof is complete, but there are some unfocused goals:\n\n";
       let iter i goal =
         let () = view#buffer#insert (goal_str (succ i)) in
-        let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in
-        view#buffer#insert msg
+        insert_xml view#buffer goal.Interface.goal_ccl;
+        view#buffer#insert "\n"
       in
       List.iteri iter bg
     end
@@ -193,6 +186,12 @@ let proof_view () =
   let () = Gtk_parsing.fix_double_click view in
   let default_clipboard = GData.clipboard Gdk.Atom.primary in
   let _ = buffer#add_selection_clipboard default_clipboard in
+  let cb clr = view#misc#modify_base [`NORMAL, `NAME clr] in
+  let _ = background_color#connect#changed cb in
+  let _ = view#misc#connect#realize (fun () -> cb background_color#get) in
+  let cb ft = view#misc#modify_font (Pango.Font.from_string ft) in
+  stick text_font view cb;
+
   object
     inherit GObj.widget view#as_widget
     val mutable goals = None
diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml
index 5cdf8464..218cedb3 100644
--- a/ide/wg_ScriptView.ml
+++ b/ide/wg_ScriptView.ml
@@ -6,6 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Preferences
+
 type insert_action = {
   ins_val : string;
   ins_off : int;
@@ -285,7 +287,7 @@ 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
+  inherit GSourceView2.source_view (Gobject.unsafe_cast tv)
 
   val undo_manager = new undo_manager view#buffer
 
@@ -456,6 +458,33 @@ object (self)
       if not proceed then GtkSignal.stop_emit ()
     in
     let _ = GtkSignal.connect ~sgn:move_line_signal ~callback obj in
+    (** Plug on preferences *)
+    let cb clr = self#misc#modify_base [`NORMAL, `NAME clr] in
+    let _ = background_color#connect#changed cb in
+    let _ = self#misc#connect#realize (fun () -> cb background_color#get) in
+
+    let cb b = self#set_wrap_mode (if b then `WORD else `NONE) in
+    stick dynamic_word_wrap self cb;
+    stick show_line_number self self#set_show_line_numbers;
+    stick auto_indent self self#set_auto_indent;
+    stick highlight_current_line self self#set_highlight_current_line;
+
+    (* Hack to handle missing binding in lablgtk *)
+    let cb b =
+      let flag = if b then 0b1001011 (* SPACE, TAB, NBSP, TRAILING *) else 0 in
+      let conv = Gobject.({ name = "draw-spaces"; conv = Data.int }) in
+      Gobject.set conv self#as_widget flag
+    in
+    stick show_spaces self cb;
+
+    stick show_right_margin self self#set_show_right_margin;
+    stick spaces_instead_of_tabs self self#set_insert_spaces_instead_of_tabs;
+    stick tab_length self self#set_tab_width;
+    stick auto_complete self self#set_auto_complete;
+
+    let cb ft = self#misc#modify_font (Pango.Font.from_string ft) in
+    stick text_font self cb;
+
     ()
 
 end
diff --git a/ide/wg_Segment.ml b/ide/wg_Segment.ml
index b4b02a7f..dbc1740e 100644
--- a/ide/wg_Segment.ml
+++ b/ide/wg_Segment.ml
@@ -7,56 +7,17 @@
 (************************************************************************)
 
 open Util
+open Preferences
 
 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
+type model_event = [ `INSERT | `REMOVE | `SET of int * color ]
 
+class type model =
+object
+  method changed : callback:(model_event -> unit) -> unit
+  method length : int
+  method fold : 'a. ('a -> color -> 'a) -> 'a -> 'a
 end
 
 let i2f = float_of_int
@@ -95,10 +56,12 @@ object (self)
 
   val mutable width = 1
   val mutable height = 20
-  val mutable data = Segment.empty
+  val mutable model : model option = None
   val mutable default : color = `WHITE
   val mutable pixmap : GDraw.pixmap = GDraw.pixmap ~width:1 ~height:1 ()
   val clicked = new GUtil.signal ()
+  val mutable need_refresh = false
+  val refresh_timer = Ideutils.mktimer ()
 
   initializer
     box#misc#set_size_request ~height ();
@@ -113,29 +76,41 @@ object (self)
       end
     in
     let _ = box#misc#connect#size_allocate cb in
-    let clicked_cb ev =
+    let clicked_cb ev = match model with
+    | None -> true
+    | Some md ->
       let x = GdkEvent.Button.x ev in
       let (width, _) = pixmap#size in
-      let len = Segment.length data in
+      let len = md#length in
       let idx = f2i ((x *. i2f len) /. i2f width) in
       let () = clicked#call idx in
       true
     in
     let _ = eventbox#event#connect#button_press clicked_cb in
+    let cb show = if show then self#misc#show () else self#misc#hide () in
+    stick show_progress_bar self cb;
     (** 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 ()
+    draw#set_pixmap pixmap;
+    refresh_timer.Ideutils.run ~ms:300
+      ~callback:(fun () -> if need_refresh then self#refresh (); true)
+
+  method set_model md =
+    model <- Some md;
+    let changed_cb = function
+    | `INSERT | `REMOVE ->
+      if self#misc#visible then need_refresh <- true
+    | `SET (i, color) ->
+      if self#misc#visible then self#fill_range color i (i + 1)
+    in
+    md#changed changed_cb
 
-  method private fill_range color i j =
+  method private fill_range color i j = match model with
+  | None -> ()
+  | Some md ->
     let i = i2f i in
     let j = i2f j in
     let width = i2f width in
-    let len = i2f (Segment.length data) in
+    let len = i2f md#length in
     let x = f2i ((i *. width) /. len) in
     let x' = f2i ((j *. width) /. len) in
     let w = x' - x in
@@ -143,14 +118,6 @@ object (self)
     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
 
@@ -159,11 +126,24 @@ object (self)
     draw#set_pixmap pixmap;
     self#refresh ();
 
-  method private refresh () =
+  method private refresh () = match model with
+  | None -> ()
+  | Some md ->
+    need_refresh <- false;
     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 ();
+    let make (k, cur, accu) v = match cur with
+    | None -> pred k, Some (k, k, v), accu
+    | Some (i, j, w) ->
+      if k = j - 1 && color_eq v w then pred k, Some (k, i, w), accu
+      else pred k, Some (k, k, v), (i, j, w) :: accu
+    in
+    let _, p, segments = md#fold make (md#length - 1, None, []) in
+    let segments = match p with
+    | None -> segments
+    | Some p -> p :: segments
+    in
+    List.iter (fun (i, j, v) -> self#fill_range v i (j + 1)) segments;
     draw#set_mask None;
 
   method connect =
diff --git a/ide/wg_Segment.mli b/ide/wg_Segment.mli
index 0fc8ebd7..29cbbeda 100644
--- a/ide/wg_Segment.mli
+++ b/ide/wg_Segment.mli
@@ -8,6 +8,8 @@
 
 type color = GDraw.color
 
+type model_event = [ `INSERT | `REMOVE | `SET of int * color ]
+
 class type segment_signals =
 object
   inherit GObj.misc_signals
@@ -15,15 +17,19 @@ object
   method clicked : callback:(int -> unit) -> GtkSignal.id
 end
 
+class type model =
+object
+  method changed : callback:(model_event -> unit) -> unit
+  method length : int
+  method fold : 'a. ('a -> color -> 'a) -> 'a -> 'a
+end
+
 class segment : unit ->
   object
     inherit GObj.widget
     val obj : Gtk.widget Gtk.obj
+    method set_model : model -> unit
     method connect : segment_signals
-    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/lib/xml_lexer.mli b/ide/xml_lexer.mli
index e61cb055..e61cb055 100644
--- a/lib/xml_lexer.mli
+++ b/ide/xml_lexer.mli
diff --git a/lib/xml_lexer.mll b/ide/xml_lexer.mll
index 290f2c89..290f2c89 100644
--- a/lib/xml_lexer.mll
+++ b/ide/xml_lexer.mll
diff --git a/lib/xml_parser.ml b/ide/xml_parser.ml
index 8db3f9e8..8db3f9e8 100644
--- a/lib/xml_parser.ml
+++ b/ide/xml_parser.ml
diff --git a/lib/xml_parser.mli b/ide/xml_parser.mli
index ac2eab35..ac2eab35 100644
--- a/lib/xml_parser.mli
+++ b/ide/xml_parser.mli
diff --git a/lib/xml_printer.ml b/ide/xml_printer.ml
index e7e4d0ce..40ab4ce9 100644
--- a/lib/xml_printer.ml
+++ b/ide/xml_printer.ml
@@ -17,65 +17,65 @@ 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 puts = Buffer.add_string tmp in
+  let putc = 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;"
+      | ' ' -> puts "&nbsp;";
+      | '>' -> puts "&gt;"
+      | '<' -> puts "&lt;"
       | '&' ->
         if p < l - 1 && text.[p + 1] = '#' then
-          output' '&'
+          putc '&'
         else
-          output "&amp;"
-      | '\'' -> output "&apos;"
-      | '"' -> output "&quot;"
-      | c -> output' c
+          puts "&amp;"
+      | '\'' -> puts "&apos;"
+      | '"' -> puts "&quot;"
+      | c -> putc 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 puts = Buffer.add_string tmp in
+  let putc = Buffer.add_char tmp in
+  putc ' ';
+  puts n;
+  puts "=\"";
   let l = String.length v in
   for p = 0 to l - 1 do
     match v.[p] with
-      | '\\' -> output "\\\\"
-      | '"' -> output "\\\""
-      | '<' -> output "&lt;"
-      | '&' -> output "&amp;"
-      | c -> output' c
+      | '\\' -> puts "\\\\"
+      | '"' -> puts "\\\""
+      | '<' -> puts "&lt;"
+      | '&' -> puts "&amp;"
+      | c -> putc c
   done;
-  output' '"'
+  putc '"'
 
 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 puts = Buffer.add_string tmp in
+  let putc = Buffer.add_char tmp in
   let rec loop = function
     | Element (tag,alist,[]) ->
-      output' '<';
-      output tag;
+      putc '<';
+      puts tag;
       List.iter (buffer_attr tmp) alist;
-      output "/>";
+      puts "/>";
       pcdata := false;
     | Element (tag,alist,l) ->
-      output' '<';
-      output tag;
+      putc '<';
+      puts tag;
       List.iter (buffer_attr tmp) alist;
-      output' '>';
+      putc '>';
       pcdata := false;
       List.iter loop l;
-      output "</";
-      output tag;
-      output' '>';
+      puts "</";
+      puts tag;
+      putc '>';
       pcdata := false;
     | PCData text ->
-      if !pcdata then output' ' ';
+      if !pcdata then putc ' ';
       buffer_pcdata tmp text;
       pcdata := true;
   in
@@ -93,42 +93,42 @@ let to_string x =
 
 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 puts = Buffer.add_string tmp in
+  let putc = Buffer.add_char tmp in
   let rec loop ?(newl=false) tab = function
     | Element (tag, alist, []) ->
-      output tab;
-      output' '<';
-      output tag;
+      puts tab;
+      putc '<';
+      puts tag;
       List.iter (buffer_attr tmp) alist;
-      output "/>";
-      if newl then output' '\n';
+      puts "/>";
+      if newl then putc '\n';
     | Element (tag, alist, [PCData text]) ->
-      output tab;
-      output' '<';
-      output tag;
+      puts tab;
+      putc '<';
+      puts tag;
       List.iter (buffer_attr tmp) alist;
-      output ">";
+      puts ">";
       buffer_pcdata tmp text;
-      output "</";
-      output tag;
-      output' '>';
-      if newl then output' '\n';
+      puts "</";
+      puts tag;
+      putc '>';
+      if newl then putc '\n';
     | Element (tag, alist, l) ->
-      output tab;
-      output' '<';
-      output tag;
+      puts tab;
+      putc '<';
+      puts tag;
       List.iter (buffer_attr tmp) alist;
-      output ">\n";
+      puts ">\n";
       List.iter (loop ~newl:true (tab^"  ")) l;
-      output tab;
-      output "</";
-      output tag;
-      output' '>';
-      if newl then output' '\n';
+      puts tab;
+      puts "</";
+      puts tag;
+      putc '>';
+      if newl then putc '\n';
     | PCData text ->
       buffer_pcdata tmp text;
-      if newl then output' '\n';
+      if newl then putc '\n';
   in
   loop "" x;
   Buffer.contents tmp
diff --git a/lib/xml_printer.mli b/ide/xml_printer.mli
index f24f51ff..f24f51ff 100644
--- a/lib/xml_printer.mli
+++ b/ide/xml_printer.mli
diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml
index 88bd2c17..aecb317b 100644
--- a/ide/xmlprotocol.ml
+++ b/ide/xmlprotocol.ml
@@ -10,7 +10,7 @@
 
 (** WARNING: TO BE UPDATED WHEN MODIFIED! *)
 
-let protocol_version = "20140312"
+let protocol_version = "20150913"
 
 (** * Interface of calls to Coq by CoqIde *)
 
@@ -39,7 +39,7 @@ let to_search_cst = do_match "search_cst" (fun s args -> match s with
   | "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)
+  | x -> raise (Marshal_error("search",PCData x)))
 
 let of_coq_object f ans =
   let prefix = of_list of_string ans.coq_object_prefix in
@@ -56,7 +56,7 @@ let to_coq_object f = function
     coq_object_qualid = qualid;
     coq_object_object = obj;
   }
-| _ -> raise Marshal_error
+| x -> raise (Marshal_error("coq_object",x))
 
 let of_option_value = function
   | IntValue i -> constructor "option_value" "intvalue" [of_option of_int i]
@@ -68,7 +68,7 @@ let to_option_value = do_match "option_value" (fun s args -> match s with
   | "boolvalue" -> BoolValue (to_bool (singleton args))
   | "stringvalue" -> StringValue (to_string (singleton args))
   | "stringoptvalue" -> StringOptValue (to_option to_string (singleton args))
-  | _ -> raise Marshal_error)
+  | x -> raise (Marshal_error("*value",PCData x)))
 
 let of_option_state s =
   Element ("option_state", [], [
@@ -82,8 +82,20 @@ let to_option_state = function
       opt_depr = to_bool depr;
       opt_name = to_string name;
       opt_value = to_option_value value }
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error("option_state",x))
 
+let to_stateid = function
+  | Element ("state_id",["val",i],[]) ->
+      let id = int_of_string i in
+      Stateid.of_int id
+  | _ -> raise (Invalid_argument "to_state_id")
+
+let of_stateid i = Element ("state_id",["val",string_of_int (Stateid.to_int i)],[])
+
+let of_richpp x = Element ("richpp", [], [Richpp.repr x])
+let to_richpp xml = match xml with
+  | Element ("richpp", [], [x]) -> Richpp.richpp_of_xml x
+  | x -> raise Serialize.(Marshal_error("richpp",x))
 
 let of_value f = function
 | Good x -> Element ("value", ["val", "good"], [f x])
@@ -91,8 +103,9 @@ let of_value f = function
   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 id = of_stateid id in
+  Element ("value", ["val", "fail"] @ loc, [id; of_richpp msg])
+
 let to_value f = function
 | Element ("value", attrs, l) ->
   let ans = massoc "val" attrs in
@@ -103,13 +116,14 @@ let to_value f = function
         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
+      with Marshal_error _ | Failure _ -> None
     in
-    let id = Stateid.of_xml (List.hd l) in
-    let msg = raw_string (List.tl l) in
+    let (id, msg) = match l with [id; msg] -> (id, msg) | _ -> raise (Marshal_error("val",PCData "no id attribute")) in
+    let id = to_stateid id in
+    let msg = to_richpp msg in
     Fail (id, loc, msg)
-  else raise Marshal_error
-| _ -> raise Marshal_error
+  else raise (Marshal_error("good or fail",PCData ans))
+| x -> raise (Marshal_error("value",x))
 
 let of_status s =
   let of_so = of_option of_string in
@@ -125,25 +139,25 @@ let to_status = function
       status_proofname = to_option to_string name;
       status_allproofs = to_list to_string prfs;
       status_proofnum = to_int pnum; }
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error("status",x))
 
 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
+  | x -> raise (Marshal_error("evar",x))
 
 let of_goal g =
-  let hyp = of_list of_string g.goal_hyp in
-  let ccl = of_string g.goal_ccl in
+  let hyp = of_list of_richpp g.goal_hyp in
+  let ccl = of_richpp 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 hyp = to_list to_richpp hyp in
+    let ccl = to_richpp ccl in
     let id = to_string id in
     { goal_hyp = hyp; goal_ccl = ccl; goal_id = id; }
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error("goal",x))
 
 let of_goals g =
   let of_glist = of_list of_goal in
@@ -161,7 +175,7 @@ let to_goals = function
     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
+  | x -> raise (Marshal_error("goals",x))
 
 let of_coq_info info =
   let version = of_string info.coqtop_version in
@@ -175,7 +189,7 @@ let to_coq_info = function
       protocol_version = to_string protocol;
       release_date = to_string release;
       compile_date = to_string compile; }
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error("coq_info",x))
 
 end
 include Xml_marshalling
@@ -220,22 +234,31 @@ module ReifType : sig
 
 end = struct
 
-  type value_type =
-    | Unit | String | Int | Bool | Xml
+  type _ val_t =
+    | Unit : unit val_t
+    | String : string val_t
+    | Int : int val_t
+    | Bool : bool val_t
+    | Xml : Xml_datatype.xml val_t
 
-    | Option of value_type
-    | List of value_type
-    | Pair of value_type * value_type
-    | Union of value_type * value_type
+    | Option : 'a val_t -> 'a option val_t
+    | List : 'a val_t -> 'a list val_t
+    | Pair : 'a val_t * 'b val_t -> ('a * 'b) val_t
+    | Union : 'a val_t * 'b val_t -> ('a, 'b) union val_t
 
-    | Goals | Evar | State | Option_state | Option_value | Coq_info
-    | Coq_object of value_type
-    | State_id
-    | Search_cst
+    | Goals : goals val_t
+    | Evar : evar val_t
+    | State : status val_t
+    | Option_state : option_state val_t
+    | Option_value : option_value val_t
+    | Coq_info : coq_info val_t
+    | Coq_object : 'a val_t -> 'a coq_object val_t
+    | State_id : state_id val_t
+    | Search_cst : search_constraint val_t
 
-  type 'a val_t = value_type
+  type value_type = Value_type : 'a val_t -> value_type
 
-  let erase (x : 'a val_t) : value_type = x
+  let erase (x : 'a val_t) = Value_type x
 
   let unit_t         = Unit
   let string_t       = String
@@ -259,48 +282,48 @@ end = struct
   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
+    let rec convert : type a. a val_t -> a -> xml = function
+      | Unit          -> of_unit
+      | Bool          -> of_bool
+      | Xml           -> (fun x -> x)
+      | String        -> of_string
+      | Int           -> of_int
+      | State         -> of_status
+      | Option_state  -> of_option_state
+      | Option_value  -> of_option_value
+      | Coq_info      -> of_coq_info
+      | Goals         -> of_goals
+      | Evar          -> of_evar
+      | List t        -> (of_list (convert t))
+      | Option t      -> (of_option (convert t))
+      | Coq_object t  -> (of_coq_object (convert t))
+      | Pair (t1,t2)  -> (of_pair (convert t1) (convert t2))
+      | Union (t1,t2) -> (of_union (convert t1) (convert t2))
+      | State_id      -> of_stateid
+      | Search_cst    -> 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
+    let rec convert : type a. a val_t -> xml -> a = function
+      | Unit          -> to_unit
+      | Bool          -> to_bool
+      | Xml           -> (fun x -> x)
+      | String        -> to_string
+      | Int           -> to_int
+      | State         -> to_status
+      | Option_state  -> to_option_state
+      | Option_value  -> to_option_value
+      | Coq_info      -> to_coq_info
+      | Goals         -> to_goals
+      | Evar          -> to_evar
+      | List t        -> (to_list (convert t))
+      | Option t      -> (to_option (convert t))
+      | Coq_object t  -> (to_coq_object (convert t))
+      | Pair (t1,t2)  -> (to_pair (convert t1) (convert t2))
+      | Union (t1,t2) -> (to_union (convert t1) (convert t2))
+      | State_id      -> to_stateid
+      | Search_cst    -> to_search_cst
     in
       convert ty
 
@@ -320,10 +343,9 @@ end = struct
               (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 Richpp.raw_print hyps) ^ " |- " ^
+            Richpp.raw_print goal ^ "]" in
       String.concat " " (List.map pr_goal g.fg_goals)
   let pr_evar (e : evar) = "[" ^ e.evar_info ^ "]"
   let pr_status (s : status) =
@@ -350,6 +372,7 @@ end = struct
   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_state_id = Stateid.to_string
 
   let pr_search_cst = function
     | Name_Pattern s -> "Name_Pattern " ^ s
@@ -358,30 +381,30 @@ end = struct
     | 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
+  let rec print : type a. a val_t -> a -> string = function
+  | Unit          -> pr_unit
+  | Bool          -> pr_bool
+  | String        -> pr_string
+  | Xml           -> Xml_printer.to_string_fmt
+  | Int           -> pr_int
+  | State         -> pr_status
+  | Option_state  -> pr_option_state
+  | Option_value  -> pr_option_value
+  | Search_cst    -> pr_search_cst
+  | Coq_info      -> pr_coq_info
+  | Goals         -> pr_goal
+  | Evar          -> pr_evar
+  | List t        -> (pr_list (print t))
+  | Option t      -> (pr_option (print t))
+  | Coq_object t  -> pr_coq_object
+  | Pair (t1,t2)  -> (pr_pair (print t1) (print t2))
+  | Union (t1,t2) -> (pr_union (print t1) (print t2))
+  | State_id      -> pr_state_id
 
   (* This is to break if a rename/refactoring makes the strings below outdated *)
   type 'a exists = bool
 
-  let rec print_type = function
+  let rec print_val_t : type a. a val_t -> string = function
   | Unit          -> "unit"
   | Bool          -> "bool"
   | String        -> "string"
@@ -394,33 +417,35 @@ end = struct
   | 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)
+  | List t        -> Printf.sprintf "(%s list)" (print_val_t t)
+  | Option t      -> Printf.sprintf "(%s option)" (print_val_t 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)
+                     Printf.sprintf "(%s Interface.coq_object)" (print_val_t t)
+  | Pair (t1,t2)  -> Printf.sprintf "(%s * %s)" (print_val_t t1) (print_val_t t2)
   | Union (t1,t2) -> assert(true : ('a,'b) CSig.union exists);
-                     Printf.sprintf "((%s, %s) CSig.union)" (print_type t1) (print_type t2)
+                     Printf.sprintf "((%s, %s) CSig.union)" (print_val_t t1) (print_val_t t2)
   | State_id      -> assert(true : Stateid.t exists); "Stateid.t"
 
+  let print_type = function Value_type ty -> print_val_t ty
+
   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)
+    Printf.printf "%s:\n\n%s\n\n" (print_val_t Unit) (pr_xml (of_unit ()));
+    Printf.printf "%s:\n\n%s\n%s\n\n" (print_val_t 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))
+    Printf.printf "%s:\n\n%s\n\n" (print_val_t String) (pr_xml (of_string "hello"));
+    Printf.printf "%s:\n\n%s\n\n" (print_val_t Int) (pr_xml (of_int 256));
+    Printf.printf "%s:\n\n%s\n\n" (print_val_t State_id) (pr_xml (of_stateid Stateid.initial));
+    Printf.printf "%s:\n\n%s\n\n" (print_val_t (List Int)) (pr_xml (of_list of_int [3;4;5]));
+    Printf.printf "%s:\n\n%s\n%s\n\n" (print_val_t (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)))
+    Printf.printf "%s:\n\n%s\n\n" (print_val_t (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)))
+    Printf.printf "%s:\n\n%s\n\n" (print_val_t (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)
+    Printf.printf "%s:\n\n%s\n\n" (print_val_t Option_state)
       (pr_xml (of_option_state { opt_sync = true; opt_depr = false;
         opt_name = "name1"; opt_value = IntValue (Some 37) }));
 
@@ -496,27 +521,27 @@ let calls = [|
 |]
 
 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
+  | Add        : add_sty -> add_rty call
+  | Edit_at    : edit_at_sty -> edit_at_rty call
+  | Query      : query_sty -> query_rty call
+  | Goal       : goals_sty -> goals_rty call
+  | Evars      : evars_sty -> evars_rty call
+  | Hints      : hints_sty -> hints_rty call
+  | Status     : status_sty -> status_rty call
+  | Search     : search_sty -> search_rty call
+  | GetOptions : get_options_sty -> get_options_rty call
+  | SetOptions : set_options_sty -> set_options_rty call
+  | MkCases    : mkcases_sty -> mkcases_rty call
+  | Quit       : quit_sty -> quit_rty call
+  | About      : about_sty -> about_rty call
+  | Init       : init_sty -> init_rty call
+  | StopWorker : stop_worker_sty -> stop_worker_rty call
   (* retrocompatibility *)
-  | Interp     of interp_sty
-  | PrintAst   of print_ast_sty
-  | Annotate   of annotate_sty
+  | Interp     : interp_sty -> interp_rty call
+  | PrintAst   : print_ast_sty -> print_ast_rty call
+  | Annotate   : annotate_sty -> annotate_rty call
 
-let id_of_call = function
+let id_of_call : type a. a call -> int = function
   | Add _        -> 0
   | Edit_at _    -> 1
   | Query _      -> 2
@@ -538,7 +563,7 @@ let id_of_call = function
 
 let str_of_call c = pi1 calls.(id_of_call c)
 
-type unknown
+type unknown_call = Unknown : 'a call -> unknown_call
 
 (** We use phantom types and GADT to protect ourselves against wild casts *)
 let add x         : add_rty call         = Add x
@@ -559,8 +584,8 @@ 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
+let abstract_eval_call : type a. _ -> a call -> a value = fun handler c ->
+  let mkGood : type a. a -> a value = fun x -> Good x in
   try
     match c with
     | Add x        -> mkGood (handler.add x)
@@ -582,51 +607,51 @@ let abstract_eval_call handler (c : 'a call) : 'a value =
     | PrintAst x   -> mkGood (handler.print_ast x)
     | Annotate x   -> mkGood (handler.annotate x)
   with any ->
-    let any = Errors.push any in
+    let any = CErrors.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 of_answer : type a. a call -> a value -> xml = function
+  | Add _        -> of_value (of_value_type add_rty_t        )
+  | Edit_at _    -> of_value (of_value_type edit_at_rty_t    )
+  | Query _      -> of_value (of_value_type query_rty_t      )
+  | Goal _       -> of_value (of_value_type goals_rty_t      )
+  | Evars _      -> of_value (of_value_type evars_rty_t      )
+  | Hints _      -> of_value (of_value_type hints_rty_t      )
+  | Status _     -> of_value (of_value_type status_rty_t     )
+  | Search _     -> of_value (of_value_type search_rty_t     )
+  | GetOptions _ -> of_value (of_value_type get_options_rty_t)
+  | SetOptions _ -> of_value (of_value_type set_options_rty_t)
+  | MkCases _    -> of_value (of_value_type mkcases_rty_t    )
+  | Quit _       -> of_value (of_value_type quit_rty_t       )
+  | About _      -> of_value (of_value_type about_rty_t      )
+  | Init _       -> of_value (of_value_type init_rty_t       )
+  | Interp _     -> of_value (of_value_type interp_rty_t     )
+  | StopWorker _ -> of_value (of_value_type stop_worker_rty_t)
+  | PrintAst _   -> of_value (of_value_type print_ast_rty_t  )
+  | Annotate _   -> of_value (of_value_type annotate_rty_t   )
+
+let to_answer : type a. a call -> xml -> a value = function
+  | Add _        -> to_value (to_value_type add_rty_t        )
+  | Edit_at _    -> to_value (to_value_type edit_at_rty_t    )
+  | Query _      -> to_value (to_value_type query_rty_t      )
+  | Goal _       -> to_value (to_value_type goals_rty_t      )
+  | Evars _      -> to_value (to_value_type evars_rty_t      )
+  | Hints _      -> to_value (to_value_type hints_rty_t      )
+  | Status _     -> to_value (to_value_type status_rty_t     )
+  | Search _     -> to_value (to_value_type search_rty_t     )
+  | GetOptions _ -> to_value (to_value_type get_options_rty_t)
+  | SetOptions _ -> to_value (to_value_type set_options_rty_t)
+  | MkCases _    -> to_value (to_value_type mkcases_rty_t    )
+  | Quit _       -> to_value (to_value_type quit_rty_t       )
+  | About _      -> to_value (to_value_type about_rty_t      )
+  | Init _       -> to_value (to_value_type init_rty_t       )
+  | Interp _     -> to_value (to_value_type interp_rty_t     )
+  | StopWorker _ -> to_value (to_value_type stop_worker_rty_t)
+  | PrintAst _   -> to_value (to_value_type print_ast_rty_t  )
+  | Annotate _   -> to_value (to_value_type annotate_rty_t   )
+
+let of_call : type a. a call -> xml = fun q ->
   let mkCall x = constructor "call" (str_of_call q) [x] in
   match q with
   | Add x        -> mkCall (of_value_type add_sty_t         x)
@@ -648,59 +673,59 @@ let of_call (q : 'a call) : xml =
   | 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 =
+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)
+    | "Add"        -> Unknown (Add        (mkCallArg add_sty_t         a))
+    | "Edit_at"    -> Unknown (Edit_at    (mkCallArg edit_at_sty_t     a))
+    | "Query"      -> Unknown (Query      (mkCallArg query_sty_t       a))
+    | "Goal"       -> Unknown (Goal       (mkCallArg goals_sty_t       a))
+    | "Evars"      -> Unknown (Evars      (mkCallArg evars_sty_t       a))
+    | "Hints"      -> Unknown (Hints      (mkCallArg hints_sty_t       a))
+    | "Status"     -> Unknown (Status     (mkCallArg status_sty_t      a))
+    | "Search"     -> Unknown (Search     (mkCallArg search_sty_t      a))
+    | "GetOptions" -> Unknown (GetOptions (mkCallArg get_options_sty_t a))
+    | "SetOptions" -> Unknown (SetOptions (mkCallArg set_options_sty_t a))
+    | "MkCases"    -> Unknown (MkCases    (mkCallArg mkcases_sty_t     a))
+    | "Quit"       -> Unknown (Quit       (mkCallArg quit_sty_t        a))
+    | "About"      -> Unknown (About      (mkCallArg about_sty_t       a))
+    | "Init"       -> Unknown (Init       (mkCallArg init_sty_t        a))
+    | "Interp"     -> Unknown (Interp     (mkCallArg interp_sty_t      a))
+    | "StopWorker" -> Unknown (StopWorker (mkCallArg stop_worker_sty_t a))
+    | "PrintAst"   -> Unknown (PrintAst   (mkCallArg print_ast_sty_t   a))
+    | "Annotate"   -> Unknown (Annotate   (mkCallArg annotate_sty_t    a))
+    | x -> raise (Marshal_error("call",PCData x)))
 
 (** 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,None,str) -> "FAIL "^Stateid.to_string id^" ["^Richpp.raw_print str^"]"
   | Fail (id,Some(i,j),str) ->
       "FAIL "^Stateid.to_string id^
-        " ("^string_of_int i^","^string_of_int j^")["^str^"]"
+        " ("^string_of_int i^","^string_of_int j^")["^Richpp.raw_print 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 pr_full_value : type a. a call -> a value -> string = fun call value -> match call with
+  | Add _        -> pr_value_gen (print add_rty_t        ) value
+  | Edit_at _    -> pr_value_gen (print edit_at_rty_t    ) value
+  | Query _      -> pr_value_gen (print query_rty_t      ) value
+  | Goal _       -> pr_value_gen (print goals_rty_t      ) value
+  | Evars _      -> pr_value_gen (print evars_rty_t      ) value
+  | Hints _      -> pr_value_gen (print hints_rty_t      ) value
+  | Status _     -> pr_value_gen (print status_rty_t     ) value
+  | Search _     -> pr_value_gen (print search_rty_t     ) value
+  | GetOptions _ -> pr_value_gen (print get_options_rty_t) value
+  | SetOptions _ -> pr_value_gen (print set_options_rty_t) value
+  | MkCases _    -> pr_value_gen (print mkcases_rty_t    ) value
+  | Quit _       -> pr_value_gen (print quit_rty_t       ) value
+  | About _      -> pr_value_gen (print about_rty_t      ) value
+  | Init _       -> pr_value_gen (print init_rty_t       ) value
+  | Interp _     -> pr_value_gen (print interp_rty_t     ) value
+  | StopWorker _ -> pr_value_gen (print stop_worker_rty_t) value
+  | PrintAst _   -> pr_value_gen (print print_ast_rty_t  ) value
+  | Annotate _   -> pr_value_gen (print annotate_rty_t   ) value
+let pr_call : type a. a call -> string = fun call ->
   let return what x = str_of_call call ^ " " ^ print what x in
   match call with
     | Add x        -> return add_sty_t x
@@ -735,7 +760,133 @@ let document to_string_fmt =
     (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"))));
+      (Fail (Stateid.initial,Some (15,34),Richpp.richpp_of_string "error message"))));
   document_type_encoding to_string_fmt
 
+(* Moved from feedback.mli : This is IDE specific and we don't want to
+   pollute the core with it *)
+
+open Feedback
+
+let of_message_level = function
+  | Debug ->
+      Serialize.constructor "message_level" "debug" []
+  | 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
+  | "info" -> Info
+  | "notice" -> Notice
+  | "warning" -> Warning
+  | "error" -> Error
+  | x -> raise Serialize.(Marshal_error("error level",PCData x)))
+
+let of_message lvl loc msg =
+  let lvl     = of_message_level lvl in
+  let xloc    = of_option of_loc loc in
+  let content = of_richpp msg        in
+  Xml_datatype.Element ("message", [], [lvl; xloc; content])
+
+let to_message xml = match xml with
+  | Xml_datatype.Element ("message", [], [lvl; xloc; content]) ->
+      Message(to_message_level lvl, to_option to_loc xloc, to_richpp content)
+  | x -> raise (Marshal_error("message",x))
+
+let is_message xml =
+  try begin match to_message xml with
+    | Message(l,c,m) -> Some (l,c,m)
+    | _              -> None
+  end with | Marshal_error _ -> None
+
+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)
+  | "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", [x] -> to_message x
+  | x,l -> raise (Marshal_error("feedback_content",PCData (x ^ " with attributes " ^ string_of_int (List.length l)))))
+
+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 ]
+  | 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 (l,loc,m) -> constructor "feedback_content" "message" [ of_message l loc m ]
+
+let of_edit_or_state_id = function
+  | Edit id -> ["object","edit"], of_edit_id id
+  | State id -> ["object","state"], of_stateid 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(to_stateid id);
+      route = int_of_string route;
+      contents = to_feedback_content content }
+  | x -> raise (Marshal_error("feedback",x))
+
+let is_feedback = function
+  | Element ("feedback", _, _) -> true
+  | _ -> false
+
 (* vim: set foldmethod=marker: *)
+
diff --git a/ide/xmlprotocol.mli b/ide/xmlprotocol.mli
index 3f851455..1bb99897 100644
--- a/ide/xmlprotocol.mli
+++ b/ide/xmlprotocol.mli
@@ -13,7 +13,7 @@ open Xml_datatype
 
 type 'a call
 
-type unknown
+type unknown_call = Unknown : 'a call -> unknown_call
 
 val add         : add_sty         -> add_rty call
 val edit_at     : edit_at_sty     -> edit_at_rty call
@@ -43,7 +43,7 @@ val protocol_version : string
 (** * XML data marshalling *)
 
 val of_call : 'a call -> xml
-val to_call : xml -> unknown call
+val to_call : xml -> unknown_call
 
 val of_answer : 'a call -> 'a value -> xml
 val to_answer : 'a call -> xml -> 'a value
@@ -56,3 +56,17 @@ val document : (xml -> string) -> unit
 val pr_call : 'a call -> string
 val pr_value : 'a value -> string
 val pr_full_value : 'a call -> 'a value -> string
+
+(** * Serialization of rich documents *)
+val of_richpp : Richpp.richpp -> Xml_datatype.xml
+val to_richpp : Xml_datatype.xml -> Richpp.richpp
+
+(** * Serializaiton of feedback  *)
+val of_feedback : Feedback.feedback -> xml
+val to_feedback : xml -> Feedback.feedback
+val is_feedback : xml -> bool
+
+val is_message : xml -> (Feedback.level * Loc.t option * Richpp.richpp) option
+val of_message : Feedback.level -> Loc.t option -> Richpp.richpp -> xml
+(* val to_message : xml -> Feedback.message *)
+
diff --git a/interp/constrarg.ml b/interp/constrarg.ml
index d9c60a18..ca828102 100644
--- a/interp/constrarg.ml
+++ b/interp/constrarg.ml
@@ -8,9 +8,14 @@
 
 open Loc
 open Tacexpr
-open Term
 open Misctypes
 open Genarg
+open Geninterp
+
+let make0 ?dyn name =
+  let wit = Genarg.make0 name in
+  let () = Geninterp.register_val0 wit dyn in
+  wit
 
 (** This is a hack for now, to break the dependency of Genarg on constr-related
     types. We should use dedicated functions someday. *)
@@ -19,56 +24,51 @@ 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_int_or_var =
+  make0 ~dyn:(val_tag (topwit Stdarg.wit_int)) "int_or_var"
 
 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"
+  make0 "intropattern"
 
-let wit_ident = unsafe_of_type IdentArgType
+let wit_tactic : (raw_tactic_expr, glob_tactic_expr, Val.t) genarg_type =
+  make0 "tactic"
 
-let wit_var = unsafe_of_type VarArgType
+let wit_ltac = make0 ~dyn:(val_tag (topwit Stdarg.wit_unit)) "ltac"
 
-let wit_ref = Genarg.make0 None "ref"
+let wit_ident =
+  make0 "ident"
 
-let wit_quant_hyp = unsafe_of_type QuantHypArgType
+let wit_var =
+  make0 ~dyn:(val_tag (topwit wit_ident)) "var"
 
-let wit_genarg = unsafe_of_type GenArgType
+let wit_ref = make0 "ref"
 
-let wit_sort : (glob_sort, glob_sort, sorts) genarg_type =
-  Genarg.make0 None "sort"
+let wit_quant_hyp = make0 "quant_hyp"
 
-let wit_constr = unsafe_of_type ConstrArgType
+let wit_constr =
+  make0 "constr"
 
-let wit_constr_may_eval = unsafe_of_type ConstrMayEvalArgType
+let wit_uconstr = make0 "uconstr"
 
-let wit_uconstr = Genarg.make0 None "uconstr"
+let wit_open_constr = make0 ~dyn:(val_tag (topwit wit_constr)) "open_constr"
 
-let wit_open_constr = unsafe_of_type OpenConstrArgType
+let wit_constr_with_bindings = make0 "constr_with_bindings"
 
-let wit_constr_with_bindings = unsafe_of_type ConstrWithBindingsArgType
+let wit_bindings = make0 "bindings"
 
-let wit_bindings = unsafe_of_type BindingsArgType
-
-let wit_hyp_location_flag : 'a Genarg.uniform_genarg_type =
-  Genarg.make0 None "hyp_location_flag"
-
-let wit_red_expr = unsafe_of_type RedExprArgType
+let wit_red_expr = make0 "redexpr"
 
 let wit_clause_dft_concl  =
-  Genarg.make0 None "clause_dft_concl"
+  make0 "clause_dft_concl"
+
+let wit_destruction_arg =
+  make0 "destruction_arg"
 
-(** Register location *)
+(** Aliases *)
 
-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";
+let wit_reference = wit_ref
+let wit_global = wit_ref
+let wit_clause = wit_clause_dft_concl
+let wit_quantified_hypothesis = wit_quant_hyp
+let wit_intropattern = wit_intro_pattern
+let wit_redexpr = wit_red_expr
diff --git a/interp/constrarg.mli b/interp/constrarg.mli
index ebef1ada..6ccd944d 100644
--- a/interp/constrarg.mli
+++ b/interp/constrarg.mli
@@ -26,7 +26,7 @@ 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_int_or_var : (int or_var, int or_var, int) genarg_type
 
 val wit_intro_pattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type
 
@@ -38,39 +38,50 @@ val wit_ref : (reference, global_reference located or_var, global_reference) gen
 
 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
+  (constr_expr, glob_constr_and_expr, 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
+  constr with_bindings delayed_open) genarg_type
 
 val wit_bindings :
   (constr_expr bindings,
   glob_constr_and_expr bindings,
-  constr bindings Evd.sigma) genarg_type
-
-val wit_hyp_location_flag : Locus.hyp_location_flag uniform_genarg_type
+  constr bindings delayed_open) 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_tactic : (raw_tactic_expr, glob_tactic_expr, Geninterp.Val.t) genarg_type
+
+(** [wit_ltac] is subtly different from [wit_tactic]: they only change for their
+    toplevel interpretation. The one of [wit_ltac] forces the tactic and
+    discards the result. *)
+val wit_ltac : (raw_tactic_expr, glob_tactic_expr, unit) 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
+
+val wit_destruction_arg :
+  (constr_expr with_bindings destruction_arg,
+   glob_constr_and_expr with_bindings destruction_arg,
+   delayed_open_constr_with_bindings destruction_arg) genarg_type
+
+(** Aliases for compatibility *)
+
+val wit_reference : (reference, global_reference located or_var, global_reference) genarg_type
+val wit_global : (reference, global_reference located or_var, global_reference) genarg_type
+val wit_clause :  (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) genarg_type
+val wit_quantified_hypothesis : quantified_hypothesis uniform_genarg_type
+val wit_intropattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type
+val wit_redexpr :
+  ((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
diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml
index 16447002..04429851 100644
--- a/interp/constrexpr_ops.ml
+++ b/interp/constrexpr_ops.ml
@@ -40,7 +40,7 @@ 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)
+  List.flatten (List.map (function LocalRawAssum(l,_,_)->l|LocalRawDef(l,_)->[l]|LocalPattern _ -> assert false) bl)
 
 (**********************************************************************)
 (* Functions on constr_expr *)
@@ -66,7 +66,7 @@ let rec cases_pattern_expr_eq p1 p2 =
       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 &&
+      Option.equal (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
@@ -125,11 +125,10 @@ let rec constr_expr_eq e1 e2 =
       Option.equal Int.equal proj1 proj2 &&
       constr_expr_eq e1 e2 &&
       List.equal args_eq al1 al2
-  | CRecord (_, e1, l1), CRecord (_, e2, l2) ->
+  | CRecord (_, l1), CRecord (_, 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 *)
@@ -178,7 +177,7 @@ 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)) =
+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
@@ -238,7 +237,7 @@ let constr_loc = function
   | CLetIn (loc,_,_,_) -> loc
   | CAppExpl (loc,_,_) -> loc
   | CApp (loc,_,_) -> loc
-  | CRecord (loc,_,_) -> loc
+  | CRecord (loc,_) -> loc
   | CCases (loc,_,_,_,_) -> loc
   | CLetTuple (loc,_,_,_,_) -> loc
   | CIf (loc,_,_,_,_) -> loc
@@ -261,6 +260,7 @@ let cases_pattern_expr_loc = function
   | CPatRecord (loc, _) -> loc
   | CPatPrim (loc,_) -> loc
   | CPatDelimiters (loc,_,_) -> loc
+  | CPatCast(loc,_,_) -> loc
 
 let raw_cases_pattern_expr_loc = function
   | RCPatAlias (loc,_,_) -> loc
@@ -272,6 +272,7 @@ let local_binder_loc = function
   | LocalRawAssum ((loc,_)::_,_,t)
   | LocalRawDef ((loc,_),t) -> Loc.merge loc (constr_loc t)
   | LocalRawAssum ([],_,_) -> assert false
+  | LocalPattern (loc,_,_) -> loc
 
 let local_binders_loc bll = match bll with
   | [] -> Loc.ghost
@@ -293,23 +294,74 @@ let mkAppC (f,l) =
   | 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 add_name_in_env env n =
+  match snd n with
+  | Anonymous -> env
+  | Name id -> id :: env
+
+let (fresh_var, fresh_var_hook) = Hook.make ~default:(fun _ _ -> assert false) ()
+
+let expand_pattern_binders mkC bl c =
+  let rec loop bl c =
+    match bl with
+    | [] -> ([], [], c)
+    | b :: bl ->
+        let (env, bl, c) = loop bl c in
+        match b with
+        | LocalRawDef (n, _) ->
+            let env = add_name_in_env env n in
+            (env, b :: bl, c)
+        | LocalRawAssum (nl, _, _) ->
+            let env = List.fold_left add_name_in_env env nl in
+            (env, b :: bl, c)
+        | LocalPattern (loc, p, ty) ->
+            let ni = Hook.get fresh_var env c in
+            let id = (loc, Name ni) in
+            let b =
+              LocalRawAssum
+                ([id], Default Explicit,
+                 match ty with
+                 | Some ty -> ty
+                 | None -> CHole (loc, None, IntroAnonymous, None))
+            in
+            let e = CRef (Libnames.Ident (loc, ni), None) in
+            let c =
+              CCases
+                (loc, LetPatternStyle, None, [(e,None,None)],
+                 [(loc, [(loc,[p])], mkC loc bl c)])
+            in
+            (ni :: env, [b], c)
+  in
+  let (_, bl, c) = loop bl c in
+  (bl, c)
+
+let mkCProdN loc bll c =
+  let rec loop loc bll c =
+    match bll with
+    | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll ->
+        CProdN (loc,[idl,bk,t],loop (Loc.merge loc1 loc) bll c)
+    | LocalRawDef ((loc1,_) as id,b) :: bll ->
+        CLetIn (loc,id,b,loop (Loc.merge loc1 loc) bll c)
+    | [] -> c
+    | LocalRawAssum ([],_,_) :: bll -> loop loc bll c
+    | LocalPattern (loc,p,ty) :: bll -> assert false
+  in
+  let (bll, c) = expand_pattern_binders loop bll c in
+  loop loc bll c
+
+let mkCLambdaN loc bll c =
+  let rec loop loc bll c =
+    match bll with
+    | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll ->
+        CLambdaN (loc,[idl,bk,t],loop (Loc.merge loc1 loc) bll c)
+    | LocalRawDef ((loc1,_) as id,b) :: bll ->
+        CLetIn (loc,id,b,loop (Loc.merge loc1 loc) bll c)
+    | [] -> c
+    | LocalRawAssum ([],_,_) :: bll -> loop loc bll c
+    | LocalPattern (loc,p,ty) :: bll -> assert false
+  in
+  let (bll, c) = expand_pattern_binders loop bll c in
+  loop loc bll c
 
 let rec abstract_constr_expr c = function
   | [] -> c
@@ -317,6 +369,7 @@ let rec abstract_constr_expr c = function
   | LocalRawAssum (idl,bk,t)::bl ->
       List.fold_right (fun x b -> mkLambdaC([x],bk,t,b)) idl
       (abstract_constr_expr c bl)
+  | LocalPattern _::_ -> assert false
 
 let rec prod_constr_expr c = function
   | [] -> c
@@ -324,22 +377,23 @@ let rec prod_constr_expr c = function
   | LocalRawAssum (idl,bk,t)::bl ->
       List.fold_right (fun x b -> mkProdC([x],bk,t,b)) idl
       (prod_constr_expr c bl)
+  | LocalPattern _::_ -> assert false
 
 let coerce_reference_to_id = function
   | Ident (_,id) -> id
   | Qualid (loc,_) ->
-      Errors.user_err_loc (loc, "coerce_reference_to_id",
+      CErrors.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
+  | a -> CErrors.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
+  | a -> CErrors.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
index 3f5be485..a92da035 100644
--- a/interp/constrexpr_ops.mli
+++ b/interp/constrexpr_ops.mli
@@ -58,6 +58,11 @@ val mkCLambdaN : Loc.t -> local_binder list -> constr_expr -> constr_expr
 val mkCProdN : Loc.t -> local_binder list -> constr_expr -> constr_expr
 (** Same as [prod_constr_expr], with location *)
 
+val fresh_var_hook : (Names.Id.t list -> Constrexpr.constr_expr -> Names.Id.t) Hook.t
+val expand_pattern_binders :
+  (Loc.t -> local_binder list -> constr_expr -> constr_expr) ->
+  local_binder list -> constr_expr -> local_binder list * constr_expr
+
 (** {6 Destructors}*)
 
 val coerce_reference_to_id : reference -> Id.t
diff --git a/interp/constrextern.ml b/interp/constrextern.ml
index 9df8f9c2..dd8a48b8 100644
--- a/interp/constrextern.ml
+++ b/interp/constrextern.ml
@@ -8,7 +8,7 @@
 
 (*i*)
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
@@ -29,6 +29,8 @@ open Notation
 open Detyping
 open Misctypes
 open Decl_kinds
+
+module NamedDecl = Context.Named.Declaration
 (*i*)
 
 (* Translation from glob_constr to front constr *)
@@ -147,17 +149,8 @@ let extern_evar loc n l = CEvar (loc,n,l)
     For instance, in the debugger the tables of global references
     may be inaccurate *)
 
-let safe_shortest_qualid_of_global vars r =
-  try shortest_qualid_of_global vars r
-  with Not_found ->
-    match r with
-    | VarRef v -> make_qualid DirPath.empty v
-    | ConstRef c -> make_qualid DirPath.empty Names.(Label.to_id (con_label c))
-    | IndRef (i,_) | ConstructRef ((i,_),_) ->
-        make_qualid DirPath.empty Names.(Label.to_id (mind_label i))
-
 let default_extern_reference loc vars r =
-  Qualid (loc,safe_shortest_qualid_of_global vars r)
+  Qualid (loc,shortest_qualid_of_global vars r)
 
 let my_extern_reference = ref default_extern_reference
 
@@ -173,6 +166,10 @@ 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 add_cpatt_for_params ind l =
+  if !Flags.in_debugger then l else
+    Util.List.addn  (Inductiveops.inductive_nparamdecls ind) (PatVar (Loc.ghost,Anonymous)) 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
@@ -264,7 +261,7 @@ let make_pat_notation loc ntn (terms,termlists as subst) args =
 
 let mkPat loc qid l =
   (* Normally irrelevant test with v8 syntax, but let's do it anyway *)
-  if List.is_empty 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,None,l)
 
 let pattern_printable_in_both_syntax (ind,_ as c) =
   let impl_st = extract_impargs_data (implicits_of_global (ConstructRef c)) in
@@ -284,7 +281,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat =
 	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, [])
+      CPatCstr (loc, c, Some (add_patt_for_params (fst cstrsp) args), [])
     | _ ->
   try
     if !Flags.raw_print || !print_no_symbol then raise No_match;
@@ -297,7 +294,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat =
   with No_match ->
     try
       if !Flags.raw_print || !print_no_symbol then raise No_match;
-      extern_symbol_pattern scopes vars pat
+      extern_notation_pattern scopes vars pat
 	(uninterp_cases_pattern_notations pat)
     with No_match ->
       match pat with
@@ -325,15 +322,15 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat =
 	    with
 		Not_found | No_match | Exit ->
                   let c = extern_reference loc Id.Set.empty (ConstructRef cstrsp) in
-		  if !Topconstr.oldfashion_patterns then
+		  if !Topconstr.asymmetric_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, [])
+		    then CPatCstr (loc, c, None, args)
+		    else CPatCstr (loc, c, Some (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, [])
+		      |Some true_args -> CPatCstr (loc, c, None, true_args)
+		      |None -> CPatCstr (loc, c, Some 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 =
@@ -356,7 +353,7 @@ and apply_notation_to_pattern loc gr ((subst,substlist),(nb_to_drop,more_args))
 		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
+	    let l2' = if !Topconstr.asymmetric_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
@@ -372,7 +369,7 @@ and apply_notation_to_pattern loc gr ((subst,substlist),(nb_to_drop,more_args))
           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
+      let l2' = if !Topconstr.asymmetric_patterns then l2
 	else
 	  match drop_implicits_in_patt gr (nb_to_drop + List.length l1) l2 with
 	    |Some true_args -> true_args
@@ -380,7 +377,7 @@ and apply_notation_to_pattern loc gr ((subst,substlist),(nb_to_drop,more_args))
       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
+and extern_notation_pattern (tmp_scope,scopes as allscopes) vars t = function
   | [] -> raise No_match
   | (keyrule,pat,n as _rule)::rules ->
     try
@@ -393,9 +390,9 @@ and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function
 	| 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
+	No_match -> extern_notation_pattern allscopes vars t rules
 
-let rec extern_symbol_ind_pattern allscopes vars ind args = function
+let rec extern_notation_ind_pattern allscopes vars ind args = function
   | [] -> raise No_match
   | (keyrule,pat,n as _rule)::rules ->
     try
@@ -403,7 +400,7 @@ let rec extern_symbol_ind_pattern allscopes vars ind args = function
       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
+	No_match -> extern_notation_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
@@ -411,7 +408,7 @@ let extern_ind_pattern_in_scope (scopes:local_scopes) vars ind args =
   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, [])
+    CPatCstr (Loc.ghost, c, Some (add_patt_for_params ind args), [])
   else
     try
       if !Flags.raw_print || !print_no_symbol then raise No_match;
@@ -423,14 +420,14 @@ let extern_ind_pattern_in_scope (scopes:local_scopes) vars ind args =
     with No_match ->
       try
 	if !Flags.raw_print || !print_no_symbol then raise No_match;
-	extern_symbol_ind_pattern scopes vars ind args
+	extern_notation_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, [])
+	   |Some true_args -> CPatCstr (Loc.ghost, c, None, true_args)
+	   |None -> CPatCstr (Loc.ghost, c, Some args, [])
 
 let extern_cases_pattern vars p =
   extern_cases_pattern_in_scope (None,[]) vars p
@@ -462,15 +459,6 @@ let is_needed_for_correct_partial_application tail 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 *)
 let explicitize loc inctx impl (cf,f) args =
@@ -484,15 +472,15 @@ let explicitize loc inctx impl (cf,f) args =
           (!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))
+	   (not (is_inferable_implicit inctx n imp) || !Flags.beautify) &&
+	   is_significant_implicit (Lazy.force a))
 	in
         if visible then
-	  (a,Some (Loc.ghost, ExplByName (name_of_implicit imp))) :: tail
+	  (Lazy.force 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*)
+    | a::args, _::impl -> (Lazy.force a,None) :: exprec (q+1) (args,impl)
+    | args, [] -> List.map (fun a -> (Lazy.force a,None)) args (*In case of polymorphism*)
     | [], (imp :: _) when is_status_implicit imp && maximal_insertion_of imp -> 
       (* The non-explicit application cannot be parsed back with the same type *)
       raise Expl
@@ -519,7 +507,7 @@ let explicitize loc inctx impl (cf,f) args =
     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)
+	CAppExpl (loc, (ip, f', us), List.map Lazy.force args)
 
 let is_start_implicit = function
   | imp :: _ -> is_status_implicit imp && maximal_insertion_of imp
@@ -541,19 +529,21 @@ let extern_app loc inctx impl (cf,f) us args =
       (!print_implicits && not !print_implicits_explicit_args)) &&
      List.exists is_status_implicit impl)
   then
+    let args = List.map Lazy.force args in
     CAppExpl (loc, (is_projection (List.length args) cf,f,us), args)
   else
     explicitize loc inctx impl (cf,CRef (f,us)) args
 
-let rec extern_args extern scopes env args subscopes =
-  match args with
-    | [] -> []
-    | a::args ->
-	let argscopes, subscopes = match subscopes with
-	  | [] -> (None,scopes), []
-	  | scopt::subscopes -> (scopt,scopes), subscopes in
-	extern argscopes env a :: extern_args extern scopes env args subscopes
+let rec fill_arg_scopes args subscopes scopes = match args, subscopes with
+| [], _ -> []
+| a :: args, scopt :: subscopes ->
+  (a, (scopt, scopes)) :: fill_arg_scopes args subscopes scopes
+| a :: args, [] ->
+  (a, (None, scopes)) :: fill_arg_scopes args [] scopes
 
+let extern_args extern env args =
+  let map (arg, argscopes) = lazy (extern argscopes env arg) in
+  List.map map args
 
 let match_coercion_app = function
   | GApp (loc,GRef (_,r,_),args) -> Some (loc, r, 0, args)
@@ -629,7 +619,7 @@ let rec extern inctx scopes vars r =
   try
     let r'' = flatten_application r' in
     if !Flags.raw_print || !print_no_symbol then raise No_match;
-    extern_symbol scopes vars r'' (uninterp_notations r'')
+    extern_notation scopes vars r'' (uninterp_notations r'')
   with No_match -> match r' with
   | GRef (loc,ref,us) ->
       extern_global loc (select_stronger_impargs (implicits_of_global ref))
@@ -650,8 +640,7 @@ let rec extern inctx scopes vars r =
       (match f with
 	 | GRef (rloc,ref,us) ->
 	     let subscopes = find_arguments_scope ref in
-	     let args =
-	       extern_args (extern true) (snd scopes) vars args subscopes in
+	     let args = fill_arg_scopes args subscopes (snd scopes) in
 	     begin
 	       try
                  if !Flags.raw_print then raise Exit;
@@ -686,12 +675,14 @@ let rec extern inctx scopes vars r =
 			       match args with
 				 | [] -> raise No_match
 				     (* we give up since the constructor is not complete *)
-				 | head :: tail -> ip q locs' tail
-				     ((extern_reference loc Id.Set.empty (ConstRef c), head) :: acc)
+				 | (arg, scopes) :: tail ->
+                                     let head = extern true scopes vars arg in
+				     ip q locs' tail ((extern_reference loc Id.Set.empty (ConstRef c), head) :: acc)
 		   in
-		 CRecord (loc, None, List.rev (ip projs locals args []))
+		 CRecord (loc, List.rev (ip projs locals args []))
 	       with
 		 | Not_found | No_match | Exit ->
+                    let args = extern_args (extern true) vars args in
 		     extern_app loc inctx
 		       (select_stronger_impargs (implicits_of_global ref))
 		       (Some ref,extern_reference rloc vars ref) (extern_universes us) args
@@ -699,7 +690,7 @@ let rec extern inctx scopes vars r =
 	       
 	 | _       ->
 	   explicitize loc inctx [] (None,sub_extern false scopes vars f)
-             (List.map (sub_extern true scopes vars) args))
+             (List.map (fun c -> lazy (sub_extern true scopes vars c)) args))
 
   | GLetIn (loc,na,t,c) ->
       CLetIn (loc,(loc,na),sub_extern false scopes vars t,
@@ -721,26 +712,27 @@ let rec extern inctx scopes vars r =
 	(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 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 = add_cpatt_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)
 
@@ -764,6 +756,7 @@ let rec extern inctx scopes vars r =
 	     let listdecl =
 	       Array.mapi (fun i fi ->
                  let (bl,ty,def) = blv.(i), tyv.(i), bv.(i) in
+                 let bl = List.map (fun (p,bk,x,t) -> (Inl p,bk,x,t)) bl in
                  let (assums,ids,bl) = extern_local_binder scopes vars bl 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
@@ -780,7 +773,8 @@ let rec extern inctx scopes vars r =
 	 | GCoFix n ->
 	     let listdecl =
                Array.mapi (fun i fi ->
-                 let (_,ids,bl) = extern_local_binder scopes vars blv.(i) in
+                 let bl = List.map (fun (p,bk,x,t) -> (Inl p,bk,x,t)) blv.(i) in
+                 let (_,ids,bl) = extern_local_binder scopes vars bl 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
 		 ((Loc.ghost, fi),bl,extern_typ scopes vars0 tyv.(i),
@@ -797,7 +791,7 @@ let rec extern inctx scopes vars r =
 	     Miscops.map_cast_type (extern_typ scopes vars) c')
 
 and extern_typ (_,scopes) =
-  extern true (Some Notation.type_scope,scopes)
+  extern true (Notation.current_type_scope_name (),scopes)
 
 and sub_extern inctx (_,scopes) = extern inctx (None,scopes)
 
@@ -823,13 +817,13 @@ and factorize_lambda inctx scopes vars na bk aty c =
 
 and extern_local_binder scopes vars = function
     [] -> ([],[],[])
-  | (na,bk,Some bd,ty)::l ->
+  | (Inl na,bk,Some bd,ty)::l ->
       let (assums,ids,l) =
         extern_local_binder scopes (name_fold Id.Set.add na vars) l in
       (assums,na::ids,
        LocalRawDef((Loc.ghost,na), extern false scopes vars bd) :: l)
 
-  | (na,bk,None,ty)::l ->
+  | (Inl na,bk,None,ty)::l ->
       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)
@@ -842,11 +836,20 @@ and extern_local_binder scopes vars = function
             (na::assums,na::ids,
              LocalRawAssum([(Loc.ghost,na)],Default bk,ty) :: l))
 
+  | (Inr p,bk,Some bd,ty)::l -> assert false
+
+  | (Inr p,bk,None,ty)::l ->
+      let ty =
+        if !Flags.raw_print then Some (extern_typ scopes vars ty) else None in
+      let p = extern_cases_pattern vars p in
+      let (assums,ids,l) = extern_local_binder scopes vars l in
+      (assums,ids, LocalPattern(Loc.ghost,p,ty) :: l)
+
 and extern_eqn inctx scopes vars (loc,ids,pl,c) =
   (loc,[loc,List.map (extern_cases_pattern_in_scope scopes vars) pl],
    extern inctx scopes vars c)
 
-and extern_symbol (tmp_scope,scopes as allscopes) vars t = function
+and extern_notation (tmp_scope,scopes as allscopes) vars t = function
   | [] -> raise No_match
   | (keyrule,pat,n as _rule)::rules ->
       let loc = Glob_ops.loc_of_glob_constr t in
@@ -918,10 +921,11 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function
 	      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
+	  let args = fill_arg_scopes args argsscopes scopes in
+	  let args = extern_args (extern true) vars args in
 	  explicitize loc false argsimpls (None,e) args
       with
-	  No_match -> extern_symbol allscopes vars t rules
+	  No_match -> extern_notation allscopes vars t rules
 
 and extern_recursion_order scopes vars = function
     GStructRec -> CStructRec
@@ -986,9 +990,12 @@ let rec glob_of_pat env sigma = function
   | PRef ref -> GRef (loc,ref,None)
   | PVar id -> GVar (loc,id)
   | PEvar (evk,l) ->
-      let test (id,_,_) = function PVar id' -> Id.equal id id' | _ -> false in
+      let test decl = function PVar id' -> Id.equal (NamedDecl.get_id decl) id' | _ -> false in
       let l = Evd.evar_instance_array test (Evd.find sigma evk) l in
-      let id = Evd.evar_ident evk sigma in
+      let id = match Evd.evar_ident evk sigma with
+      | None -> Id.of_string "__"
+      | Some id -> id
+      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
@@ -1045,4 +1052,5 @@ let extern_constr_pattern env sigma pat =
 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
+  let a = List.map (fun (p,bk,x,t) -> (Inl p,bk,x,t)) a in
   pi3 (extern_local_binder (None,[]) vars a)
diff --git a/interp/constrextern.mli b/interp/constrextern.mli
index bf1f529c..f617faa3 100644
--- a/interp/constrextern.mli
+++ b/interp/constrextern.mli
@@ -8,7 +8,6 @@
 
 open Names
 open Term
-open Context
 open Termops
 open Environ
 open Libnames
@@ -42,7 +41,7 @@ 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
+  Context.Rel.t -> local_binder list
 
 (** Printing options *)
 val print_implicits : bool ref
diff --git a/interp/constrintern.ml b/interp/constrintern.ml
index a7b1bb41..e6340646 100644
--- a/interp/constrintern.ml
+++ b/interp/constrintern.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
@@ -29,13 +29,14 @@ open Nametab
 open Notation
 open Inductiveops
 open Decl_kinds
+open Context.Rel.Declaration
 
 (** constr_expr -> glob_constr translation:
     - it adds holes for implicit arguments
-    - it remplaces notations by their value (scopes stuff are here)
+    - it replaces 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)
+    - it prepares pattern matching problems (a pattern becomes a tree
+      where nodes are constructor/variable pairs and leafs are variables)
 
     All that at once, fasten your seatbelt!
 *)
@@ -101,7 +102,7 @@ let global_reference id =
 
 let construct_reference ctx id =
   try
-    Term.mkVar (let _ = Context.lookup_named id ctx in id)
+    Term.mkVar (let _ = Context.Named.lookup id ctx in id)
   with Not_found ->
     global_reference id
 
@@ -274,7 +275,8 @@ let error_expect_binder_notation_type loc id =
 
 let set_var_scope loc id istermvar env ntnvars =
   try
-    let idscopes,typ = Id.Map.find id ntnvars in
+    let isonlybinding,idscopes,typ = Id.Map.find id ntnvars in
+    if istermvar then isonlybinding := false;
     let () = if istermvar then
       (* scopes have no effect on the interpretation of identifiers *)
       begin match !idscopes with
@@ -298,7 +300,7 @@ let set_var_scope loc id istermvar env ntnvars =
     (* Not in a notation *)
     ()
 
-let set_type_scope env = {env with tmp_scope = Some Notation.type_scope}
+let set_type_scope env = {env with tmp_scope = Notation.current_type_scope_name ()}
 
 let reset_tmp_scope env = {env with tmp_scope = None}
 
@@ -367,7 +369,7 @@ let check_hidden_implicit_parameters id impls =
     errorlabstrm "" (strbrk "A parameter of an inductive type " ++
     pr_id id ++ strbrk " is not allowed to be used as a bound variable in the type of its constructor.")
 
-let push_name_env ?(global_level=false) lvar implargs env =
+let push_name_env ?(global_level=false) ntnvars implargs env =
   function
   | loc,Anonymous ->
       if global_level then
@@ -375,7 +377,6 @@ let push_name_env ?(global_level=false) lvar implargs env =
       env
   | loc,Name id ->
       check_hidden_implicit_parameters id env.impls ;
-      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;
@@ -431,14 +432,72 @@ let intern_assumption intern lvar env nal bk ty =
      let env, b = intern_generalized_binder intern_type lvar env (List.hd nal) b b' t ty in
      env, b
 
+let rec free_vars_of_pat il =
+  function
+  | CPatCstr (loc, c, l1, l2) ->
+      let il = List.fold_left free_vars_of_pat il (Option.default [] l1) in
+      List.fold_left free_vars_of_pat il l2
+  | CPatAtom (loc, ro) ->
+      begin match ro with
+      | Some (Ident (loc, i)) -> (loc, i) :: il
+      | Some _ | None -> il
+      end
+  | CPatNotation (loc, n, l1, l2) ->
+      let il = List.fold_left free_vars_of_pat il (fst l1) in
+      List.fold_left (List.fold_left free_vars_of_pat) il (snd l1)
+  | _ -> anomaly (str "free_vars_of_pat")
+
+let intern_local_pattern intern lvar env p =
+  List.fold_left
+    (fun env (loc, i) ->
+       let bk = Default Implicit in
+       let ty = CHole (loc, None, Misctypes.IntroAnonymous, None) in
+       let n = Name i in
+       let env, _ = intern_assumption intern lvar env [(loc, n)] bk ty in
+       env)
+    env (free_vars_of_pat [] p)
+
+type binder_data =
+  | BDRawDef of (Loc.t * glob_binder)
+  | BDPattern of
+      (Loc.t * (cases_pattern * Id.t list) *
+         (bool ref *
+          (Notation_term.tmp_scope_name option *
+           Notation_term.tmp_scope_name list)
+          option ref * Notation_term.notation_var_internalization_type)
+         Names.Id.Map.t *
+       intern_env * constr_expr)
+
+let intern_cases_pattern_fwd = ref (fun _ -> failwith "intern_cases_pattern_fwd")
+
 let intern_local_binder_aux ?(global_level=false) intern lvar (env,bl) = function
   | LocalRawAssum(nal,bk,ty) ->
       let env, bl' = intern_assumption intern lvar env nal bk ty in
+      let bl' = List.map (fun a -> BDRawDef a) bl' in
       env, bl' @ bl
   | LocalRawDef((loc,na as locna),def) ->
-      let indef = intern env def in
+     let indef = intern env def in
+     let term, ty =
+       match indef with
+       | GCast (loc, b, Misctypes.CastConv t) -> b, t
+       | _ -> indef, GHole(loc,Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None)
+     in
       (push_name_env lvar (impls_term_list indef) env locna,
-      (loc,(na,Explicit,Some(indef),GHole(loc,Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None)))::bl)
+       (BDRawDef ((loc,(na,Explicit,Some(term),ty))))::bl)
+  | LocalPattern (loc,p,ty) ->
+      let tyc =
+        match ty with
+        | Some ty -> ty
+        | None -> CHole(loc,None,Misctypes.IntroAnonymous,None)
+      in
+      let env = intern_local_pattern intern lvar env p in
+      let cp =
+        match !intern_cases_pattern_fwd (None,env.scopes) p with
+        | (_, [(_, cp)]) -> cp
+        | _ -> assert false
+      in
+      let il = List.map snd (free_vars_of_pat [] p) in
+      (env, BDPattern(loc,(cp,il),lvar,env,tyc) :: bl)
 
 let intern_generalization intern env lvar loc bk ak c =
   let c = intern {env with unb = true} c in
@@ -449,12 +508,15 @@ let intern_generalization intern env lvar loc bk ak c =
 	| Some AbsPi -> true
         | Some _ -> false
 	| None ->
-          let is_type_scope = match env.tmp_scope with
+          match Notation.current_type_scope_name () with
+          | Some type_scope ->
+              let is_type_scope = match env.tmp_scope with
+              | None -> false
+              | Some sc -> String.equal sc type_scope
+              in
+              is_type_scope ||
+              String.List.mem type_scope env.scopes
           | 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 ->
@@ -504,44 +566,85 @@ let traverse_binder (terms,_,_ as subst) avoid (renaming,env) = function
     in
     (renaming',env), Name id'
 
-let make_letins = List.fold_right (fun (loc,(na,b,t)) c -> GLetIn (loc,na,b,c))
-
-let rec subordinate_letins letins = function
+type letin_param =
+  | LPLetIn of Loc.t * (Name.t * glob_constr)
+  | LPCases of Loc.t * (cases_pattern * Id.t list) * Id.t
+
+let make_letins =
+  List.fold_right
+    (fun a c ->
+     match a with
+     | LPLetIn (loc,(na,b)) ->
+         GLetIn(loc,na,b,c)
+     | LPCases (loc,(cp,il),id) ->
+         let tt = (GVar(loc,id),(Name id,None)) in
+         GCases(loc,Misctypes.LetPatternStyle,None,[tt],[(loc,il,[cp],c)]))
+
+let rec subordinate_letins intern letins = function
   (* binders come in reverse order; the non-let are returned in reverse order together *)
   (* with the subordinated let-in in writing order *)
-  | (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
+  | BDRawDef (loc,(na,_,Some b,t))::l ->
+      subordinate_letins intern (LPLetIn (loc,(na,b))::letins) l
+  | BDRawDef (loc,(na,bk,None,t))::l ->
+      let letins',rest = subordinate_letins intern [] l in
       letins',((loc,(na,bk,t)),letins)::rest
+  | BDPattern (loc,u,lvar,env,tyc) :: l ->
+      let ienv = Id.Set.elements env.ids in
+      let id = Namegen.next_ident_away (Id.of_string "pat") ienv in
+      let na = (loc, Name id) in
+      let bk = Default Explicit in
+      let _, bl' = intern_assumption intern lvar env [na] bk tyc in
+      let bl' = List.map (fun a -> BDRawDef a) bl' in
+      subordinate_letins intern (LPCases (loc,u,id)::letins) (bl'@ l)
   | [] ->
       letins,[]
 
-let rec subst_iterator y t = function
-  | 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 (_,ntnvars as lvar) subst infos c =
+let terms_of_binders bl =
+  let rec term_of_pat = function
+    | PatVar (loc,Name id) -> CRef (Ident (loc,id), None)
+    | PatVar (loc,Anonymous) -> error "Cannot turn \"_\" into a term."
+    | PatCstr (loc,c,l,_) ->
+       let r = Qualid (loc,qualid_of_path (path_of_global (ConstructRef c))) in
+       let hole = CHole (loc,None,Misctypes.IntroAnonymous,None) in
+       let params = List.make (Inductiveops.inductive_nparams (fst c)) hole in
+       CAppExpl (loc,(None,r,None),params @ List.map term_of_pat l) in
+  let rec extract_variables = function
+    | BDRawDef (loc,(Name id,_,None,_))::l -> CRef (Ident (loc,id), None) :: extract_variables l
+    | BDRawDef (loc,(Name id,_,Some _,_))::l -> extract_variables l
+    | BDRawDef (loc,(Anonymous,_,_,_))::l -> error "Cannot turn \"_\" into a term."
+    | BDPattern (loc,(u,_),lvar,env,tyc) :: l -> term_of_pat u :: extract_variables l
+    | [] -> [] in
+  extract_variables bl
+
+let instantiate_notation_constr loc intern ntnvars 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 rec aux (terms,binderopt,terminopt as subst') (renaming,env) c =
     let subinfos = renaming,{env with tmp_scope = None} in
     match c with
+    | NVar id when Id.equal id ldots_var -> Option.get terminopt
     | NVar id -> subst_var subst' (renaming, env) id
-    | NList (x,_,iter,terminator,lassoc) ->
-      (try
+    | NList (x,y,iter,terminator,lassoc) ->
+      let l,(scopt,subscopes) =
         (* All elements of the list are in scopes (scopt,subscopes) *)
-	let (l,(scopt,subscopes)) = Id.Map.find x termlists in
-        let termin = aux subst' subinfos terminator in
-        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 (Pp.str "Inconsistent substitution of recursive notation"))
+        try
+          let l,scopes = Id.Map.find x termlists in
+          (if lassoc then List.rev l else l),scopes
+        with Not_found ->
+        try
+	  let (bl,(scopt,subscopes)) = Id.Map.find x binders in
+	  let env,bl' = List.fold_left (intern_local_binder_aux intern ntnvars) (env,[]) bl in
+          terms_of_binders (if lassoc then bl' else List.rev bl'),(None,[])
+        with Not_found ->
+          anomaly (Pp.str "Inconsistent substitution of recursive notation") in
+      let termin = aux (terms,None,None) subinfos terminator in
+      let fold a t =
+        let nterms = Id.Map.add y (a, (scopt, subscopes)) terms in
+        aux (nterms,None,Some t) subinfos iter
+      in
+      List.fold_right fold l termin
     | NHole (knd, naming, arg) ->
       let knd = match knd with
       | Evar_kinds.BinderType (Name id as na) ->
@@ -576,26 +679,28 @@ let subst_aconstr_in_glob_constr loc intern (_,ntnvars as lvar) subst infos c =
         Some arg
       in
       GHole (loc, knd, naming, arg)
-    | NBinderList (x,_,iter,terminator) ->
+    | NBinderList (x,y,iter,terminator) ->
       (try
         (* All elements of the list are in scopes (scopt,subscopes) *)
 	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 env,bl = List.fold_left (intern_local_binder_aux intern ntnvars) (env,[]) bl in
+	let letins,bl = subordinate_letins intern [] bl in
+        let termin = aux (terms,None,None) (renaming,env) terminator in
 	let res = List.fold_left (fun t binder ->
-          subst_iterator ldots_var t
-	    (aux (terms,Some(x,binder)) subinfos iter))
+	    aux (terms,Some(y,binder),Some t) subinfos iter)
 	  termin bl in
 	make_letins letins res
       with Not_found ->
           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'))
+        let a,letins = snd (Option.get binderopt) in
+        let e = make_letins letins (aux subst' infos c') in
+        let (loc,(na,bk,t)) = a in
+        GProd (loc,na,bk,t,e)
     | 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'))
+        let a,letins = snd (Option.get binderopt) in
+        let (loc,(na,bk,t)) = a 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' ->
@@ -610,7 +715,7 @@ let subst_aconstr_in_glob_constr loc intern (_,ntnvars as lvar) subst infos c =
     | 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 =
+  and subst_var (terms, _binderopt, _terminopt) (renaming, env) id =
     (* subst remembers the delimiters stack in the interpretation *)
     (* of the notations *)
     try
@@ -623,12 +728,12 @@ let subst_aconstr_in_glob_constr loc intern (_,ntnvars as lvar) subst infos c =
     with Not_found ->
       (* Happens for local notation joint with inductive/fixpoint defs *)
       GVar (loc,id)
-  in aux (terms,None) infos c
+  in aux (terms,None,None) infos c
 
 let split_by_type ids =
   List.fold_right (fun (x,(scl,typ)) (l1,l2,l3) ->
     match typ with
-    | NtnTypeConstr -> ((x,scl)::l1,l2,l3)
+    | NtnTypeConstr | NtnTypeOnlyBinder -> ((x,scl)::l1,l2,l3)
     | NtnTypeConstrList -> (l1,(x,scl)::l2,l3)
     | NtnTypeBinderList -> (l1,l2,(x,scl)::l3)) ids ([],[],[])
 
@@ -644,7 +749,7 @@ let intern_notation intern env lvar loc ntn fullargs =
   let terms = make_subst ids args in
   let termlists = make_subst idsl argslist in
   let binders = make_subst idsbl bll in
-  subst_aconstr_in_glob_constr loc intern lvar
+  instantiate_notation_constr loc intern lvar
     (terms, termlists, binders) (Id.Map.empty, env) c
 
 (**********************************************************************)
@@ -656,7 +761,13 @@ let string_of_ty = function
   | Method -> "meth"
   | Variable -> "var"
 
-let intern_var genv (ltacvars,ntnvars) namedctx loc id =
+let gvar (loc, id) us = match us with
+| None -> GVar (loc, id)
+| Some _ ->
+  user_err_loc (loc, "", str "Variable " ++ pr_id id ++
+    str " cannot have a universe instance")
+
+let intern_var genv (ltacvars,ntnvars) namedctx loc id us =
   (* Is [id] an inductive type potentially with implicit *)
   try
     let ty,expl_impls,impls,argsc = Id.Map.find id genv.impls in
@@ -664,28 +775,28 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id =
       (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 "<>" (Id.to_string id) tys;
-    GVar (loc,id), make_implicits_list impls, argsc, expl_impls
+    gvar (loc,id) us, 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 Id.Set.mem id genv.ids || Id.Set.mem id ltacvars.ltac_vars
   then
-    GVar (loc,id), [], [], []
+    gvar (loc,id) us, [], [], []
   (* Is [id] a notation variable *)
   else if Id.Map.mem id ntnvars
   then
-    (set_var_scope loc id true genv ntnvars; GVar (loc,id), [], [], [])
+    (set_var_scope loc id true genv ntnvars; gvar (loc,id) us, [], [], [])
   (* Is [id] the special variable for recursive notations *)
   else if Id.equal id ldots_var
   then if Id.Map.is_empty ntnvars
     then error_ldots_var loc
-    else GVar (loc,id), [], [], []
+    else gvar (loc,id) us, [], [], []
   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] a goal or section variable *)
-    let _ = Context.lookup_named id namedctx in
+    let _ = Context.Named.lookup id namedctx in
       try
 	(* [id] a section variable *)
 	(* Redundant: could be done in intern_qualid *)
@@ -693,23 +804,10 @@ 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, None), impls, scopes, []
-      with e when Errors.noncritical e ->
+	GRef (loc, ref, us), impls, scopes, []
+      with e when CErrors.noncritical e ->
 	(* [id] a goal variable *)
-	GVar (loc,id), [], [], []
-
-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
+	gvar (loc,id) us, [], [], []
 
 let find_appl_head_data c =
   match c with
@@ -767,7 +865,18 @@ let intern_qualid loc qid intern env lvar us args =
       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
+      let c = instantiate_notation_constr loc intern lvar subst infos c in
+      let c = match us, c with
+      | None, _ -> c
+      | Some _, GRef (loc, ref, None) -> GRef (loc, ref, us)
+      | Some _, GApp (loc, GRef (loc', ref, None), arg) ->
+         GApp (loc, GRef (loc', ref, us), arg)
+      | Some _, _ ->
+        user_err_loc (loc, "", str "Notation " ++ pr_qualid qid ++
+          str " cannot have a universe instance, its expanded head
+               does not start with a reference")
+      in
+      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 us args =
@@ -775,26 +884,26 @@ let intern_non_secvar_qualid loc qid intern env lvar us args =
     | GRef (_, VarRef _, _),_,_ -> raise Not_found
     | r -> r
 
-let intern_applied_reference intern env namedctx lvar us args = function
+let intern_applied_reference intern env namedctx (_, ntnvars as lvar) us args = function
   | Qualid (loc, qid) ->
       let r,projapp,args2 =
-	try intern_qualid loc qid intern env lvar us args
+	try intern_qualid loc qid intern env ntnvars 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
+      try intern_var env lvar namedctx loc id us, args
       with Not_found ->
       let qid = qualid_of_ident id in
       try
-	let r, projapp, args2 = intern_non_secvar_qualid loc qid intern env lvar us args in
+	let r, projapp, args2 = intern_non_secvar_qualid loc qid intern env ntnvars 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
+	  (gvar (loc,id) us, [], [], []), args
 	else error_global_not_found_loc loc qid
 
 let interp_reference vars r =
@@ -929,7 +1038,7 @@ let chop_params_pattern loc ind args with_letin =
   args
 
 let find_constructor loc add_params ref =
-  let cstr = match ref with
+  let (ind,_ as cstr) = match ref with
   | ConstructRef cstr -> cstr
   | IndRef _ ->
     let error = str "There is an inductive name deep in a \"in\" clause." in
@@ -938,109 +1047,136 @@ let find_constructor loc add_params ref =
     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 ->
+  cstr, match add_params with
+    | Some nb_args ->
       let nb =
-        if Int.equal nb_args (Inductiveops.constructor_nrealdecls c)
+        if Int.equal nb_args (Inductiveops.constructor_nrealdecls cstr)
           then Inductiveops.inductive_nparamdecls ind
           else Inductiveops.inductive_nparams ind
       in
       List.make nb ([], [(Id.Map.empty, PatVar(Loc.ghost,Anonymous))])
-    |None -> []) cstr
+    | None -> []
 
 let find_pattern_variable = function
   | Ident (loc,id) -> id
   | Qualid (loc,_) as x -> raise (InternalizationError(loc,NotAConstructor x))
 
-let sort_fields mode loc l completer =
-(*mode=false if pattern and true if constructor*)
-  match l with
+let check_duplicate loc fields =
+  let eq (ref1, _) (ref2, _) = eq_reference ref1 ref2 in
+  let dups = List.duplicates eq fields in
+  match dups with
+  | [] -> ()
+  | (r, _) :: _ ->
+    user_err_loc (loc, "", str "This record defines several times the field " ++
+      pr_reference r ++ str ".")
+
+(** [sort_fields ~complete loc fields completer] expects a list
+    [fields] of field assignments [f = e1; g = e2; ...], where [f, g]
+    are fields of a record and [e1] are "values" (either terms, when
+    interning a record construction, or patterns, when intering record
+    pattern-matching). It will sort the fields according to the record
+    declaration order (which is important when type-checking them in
+    presence of dependencies between fields). If the parameter
+    [complete] is true, we require the assignment to be complete: all
+    the fields of the record must be present in the
+    assignment. Otherwise the record assignment may be partial
+    (in a pattern, we may match on some fields only), and we call the
+    function [completer] to fill the missing fields; the returned
+    field assignment list is always complete. *)
+let sort_fields ~complete loc fields completer =
+  match fields with
     | [] -> None
-    | (refer, value)::rem ->
-	let (nparams,          (* the number of parameters *)
-	     base_constructor, (* the reference constructor of the record *)
-	     (max,             (* number of params *)
-	      (first_index,    (* index of the first field of the record *)
-	       list_proj)))    (* list of projections *)
-	  =
-	  let record =
-	    try Recordops.find_projection
-	      (global_reference_of_reference refer)
-	    with Not_found ->
-	      user_err_loc (loc_of_reference refer, "intern", pr_reference refer ++ str": Not a projection")
-	    in
-	  (* elimination of the first field from the projections *)
-	  let rec build_patt l m i acc =
-	    match l with
-	      | [] -> (i, acc)
-	      | (Some name) :: b->
-		 (match m with
-		    | [] -> anomaly (Pp.str "Number of projections mismatch")
-		    | (_, regular)::tm ->
-		       let boolean = not regular in
-                       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)
-                       end)
-	      | None :: b-> (* we don't want anonymous fields *)
-		 if mode then
-		   user_err_loc (loc, "", str "This record contains anonymous fields.")
-		 else build_patt b m (i+1) acc
-		   (* anonymous arguments don't appear in m *)
-	    in
-	  let ind = record.Recordops.s_CONST in
-	  try (* insertion of Constextern.reference_global *)
-	    (record.Recordops.s_EXPECTEDPARAM,
-	     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 (Pp.str "Environment corruption for records.")
-	  in
-	(* now we want to have all fields of the pattern indexed by their place in
-	   the constructor *)
-	let rec sf patts accpatt =
-	  match patts with
-	    | [] -> accpatt
-	    | p::q->
-	       let refer, patt = p in
-	       let glob_refer = try global_reference_of_reference refer
-	       with |Not_found ->
-		 user_err_loc (loc_of_reference refer, "intern",
-			       str "The field \"" ++ pr_reference refer ++ str "\" does not exist.") in
-	       let rec add_patt l acc =
-		 match l with
-		   | [] ->
-		       user_err_loc
-			 (loc, "",
-			  str "This record contains fields of different records.")
-		   | (i, a) :: b->
-		       if eq_gr glob_refer a
-		       then (i,List.rev_append acc l)
-		       else add_patt b ((i,a)::acc)
-	         in
-	       let (index, projs) = add_patt (snd accpatt) [] in
-		 sf q ((index, patt)::fst accpatt, projs) in
-	let (unsorted_indexed_pattern, remainings) =
-	  sf rem ([first_index, value], list_proj) in
-	(* we sort them *)
-	let sorted_indexed_pattern =
-	  List.sort (fun (i, _) (j, _) -> compare i j) unsorted_indexed_pattern in
-	(* a function to complete with wildcards *)
-	let rec complete_list n l =
-	  if n <= 1 then l else complete_list (n-1) (completer n l) in
-	(* a function to remove indice *)
-	let rec clean_list l i acc =
-	  match l with
-	    | [] -> complete_list (max - i) acc
-	    | (k, p)::q-> clean_list q k (p::(complete_list (k - i) acc))
-	  in
-	Some (nparams, base_constructor,
-	  List.rev (clean_list sorted_indexed_pattern 0 []))
+    | (first_field_ref, first_field_value):: other_fields ->
+        let (first_field_glob_ref, record) =
+          try
+            let gr = global_reference_of_reference first_field_ref in
+            (gr, Recordops.find_projection gr)
+          with Not_found ->
+            user_err_loc (loc_of_reference first_field_ref, "intern",
+                          pr_reference first_field_ref ++ str": Not a projection")
+        in
+        (* the number of parameters *)
+        let nparams = record.Recordops.s_EXPECTEDPARAM in
+        (* the reference constructor of the record *)
+        let base_constructor =
+          let global_record_id = ConstructRef record.Recordops.s_CONST in
+          try Qualid (loc, shortest_qualid_of_global Id.Set.empty global_record_id)
+          with Not_found ->
+            anomaly (str "Environment corruption for records") in
+        let () = check_duplicate loc fields in
+        let (end_index,    (* one past the last field index *)
+             first_field_index,  (* index of the first field of the record *)
+             proj_list)    (* list of projections *)
+          =
+          (* elimitate the first field from the projections,
+             but keep its index *)
+          let rec build_proj_list projs proj_kinds idx ~acc_first_idx acc =
+            match projs with
+              | [] -> (idx, acc_first_idx, acc)
+              | (Some name) :: projs ->
+                 let field_glob_ref = ConstRef name in
+                 let first_field = eq_gr field_glob_ref first_field_glob_ref in
+                 begin match proj_kinds with
+                    | [] -> anomaly (Pp.str "Number of projections mismatch")
+                    | (_, regular) :: proj_kinds ->
+                       (* "regular" is false when the field is defined
+                           by a let-in in the record declaration
+                           (its value is fixed from other fields). *)
+                       if first_field && not regular && complete then
+                         user_err_loc (loc, "", str "No local fields allowed in a record construction.")
+                       else if first_field then
+                         build_proj_list projs proj_kinds (idx+1) ~acc_first_idx:idx acc
+                       else if not regular && complete then
+                         (* skip non-regular fields *)
+                         build_proj_list projs proj_kinds idx ~acc_first_idx acc
+                       else
+                         build_proj_list projs proj_kinds (idx+1) ~acc_first_idx
+                                         ((idx, field_glob_ref) :: acc)
+                 end
+              | None :: projs ->
+                 if complete then
+                   (* we don't want anonymous fields *)
+                   user_err_loc (loc, "", str "This record contains anonymous fields.")
+                 else
+                   (* anonymous arguments don't appear in proj_kinds *)
+                   build_proj_list projs proj_kinds (idx+1) ~acc_first_idx acc
+          in
+          build_proj_list record.Recordops.s_PROJ record.Recordops.s_PROJKIND 1 ~acc_first_idx:0 []
+        in
+        (* now we want to have all fields assignments indexed by their place in
+           the constructor *)
+        let rec index_fields fields remaining_projs acc =
+          match fields with
+            | (field_ref, field_value) :: fields ->
+               let field_glob_ref = try global_reference_of_reference field_ref
+               with Not_found ->
+                 user_err_loc (loc_of_reference field_ref, "intern",
+                               str "The field \"" ++ pr_reference field_ref ++ str "\" does not exist.") in
+               let remaining_projs, (field_index, _) =
+                 let the_proj (idx, glob_ref) = eq_gr field_glob_ref glob_ref in
+                 try CList.extract_first the_proj remaining_projs
+                 with Not_found ->
+                   user_err_loc
+                     (loc, "",
+                      str "This record contains fields of different records.")
+               in
+               index_fields fields remaining_projs ((field_index, field_value) :: acc)
+            | [] ->
+               (* the order does not matter as we sort them next,
+                  List.rev_* is just for efficiency *)
+               let remaining_fields =
+                 let complete_field (idx, _field_ref) = (idx, completer idx) in
+                 List.rev_map complete_field remaining_projs in
+               List.rev_append remaining_fields acc
+        in
+        let unsorted_indexed_fields =
+          index_fields other_fields proj_list
+            [(first_field_index, first_field_value)] in
+        let sorted_indexed_fields =
+          let cmp_by_index (i, _) (j, _) = Int.compare i j in
+          List.sort cmp_by_index unsorted_indexed_fields in
+        let sorted_fields = List.map snd sorted_indexed_fields in
+        Some (nparams, base_constructor, sorted_fields)
 
 (** {6 Manage multiple aliases} *)
 
@@ -1068,10 +1204,6 @@ 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 :
@@ -1102,98 +1234,103 @@ let drop_notations_pattern looked_for =
   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 rec drop_syndef top scopes re pats =
     let (loc,qid) = qualid_of_reference re in
     try
       match locate_extended qid with
-      |SynDef sp ->
+      | SynDef sp ->
 	let (vars,a) = Syntax_def.search_syntactic_definition sp in
 	(match a with
 	| NRef g ->
+          (* Convention: do not deactivate implicit arguments and scopes for further arguments *)
 	  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 *)
+	  Some (g, [], List.map2 (in_pat_sc scopes) argscs pats)
+	| NApp (NRef g,[]) -> (* special case: Syndef for @Cstr, this deactivates *)
 	      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, [])
+	      Some (g, List.map (in_pat false scopes) pats, [])
 	| NApp (NRef g,args) ->
+              (* Convention: do not deactivate implicit arguments and scopes for further arguments *)
 	      test_kind top 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 idspl1 = List.map (in_not false loc scopes (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)
+	      Some (g, idspl1, List.map2 (in_pat_sc scopes) argscs pats2)
 	| _ -> raise Not_found)
-      |TrueGlobal g ->
+      | 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)
+	  Some (g,[],List.map2 (fun x -> in_pat false (x,snd scopes)) argscs pats)
     with Not_found -> None
-  and in_pat top env = function
-    | CPatAlias (loc, p, id) -> RCPatAlias (loc, in_pat top env p, id)
+  and in_pat top scopes = function
+    | CPatAlias (loc, p, id) -> RCPatAlias (loc, in_pat top scopes p, id)
     | CPatRecord (loc, l) ->
       let sorted_fields =
-	sort_fields false loc l (fun _ l -> (CPatAtom (loc, None))::l) in
+	sort_fields ~complete:false loc l (fun _idx -> (CPatAtom (loc, None))) in
       begin match sorted_fields with
 	| None -> RCPatAtom (loc, None)
 	| Some (n, head, pl) ->
           let pl =
-            if !oldfashion_patterns then pl else
+            if !asymmetric_patterns then pl else
             let pars = List.make n (CPatAtom (loc, None)) in
             List.rev_append pars pl in
-	  match drop_syndef top env head pl with
+	  match drop_syndef top scopes head pl with
 	    |Some (a,b,c) -> RCPatCstr(loc, a, b, c)
 	    |None -> raise (InternalizationError (loc,NotAConstructor head))
       end
-    | CPatCstr (loc, head, [], pl) ->
+    | CPatCstr (loc, head, None, pl) ->
       begin
-	match drop_syndef top env head pl with
+	match drop_syndef top scopes 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 ->
+     | CPatCstr (loc, r, Some 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)
+      if expl_pl == [] then
+        (* Convention: (@r) deactivates all further implicit arguments and scopes *)
+        RCPatCstr (loc, g, List.map (in_pat false scopes) pl, [])
+      else
+        (* Convention: (@r expl_pl) deactivates implicit arguments in expl_pl and in pl *)
+        (* but not scopes in expl_pl *)
+        let (argscs1,_) = find_remaining_scopes expl_pl pl g in
+        RCPatCstr (loc, g, List.map2 (in_pat_sc scopes) argscs1 expl_pl @ List.map (in_pat false scopes) 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))
+      fst (Notation.interp_prim_token_cases_pattern_expr loc (ensure_kind false loc) (Numeral (Bigint.neg p)) scopes)
     | CPatNotation (_,"( _ )",([a],[]),[]) ->
-      in_pat top env a
+      in_pat top scopes 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',c),df) = Notation.interp_notation loc ntn scopes in
       let (ids',idsl',_) = split_by_type ids' in
       Dumpglob.dump_notation_location (patntn_loc loc fullargs ntn) ntn df;
       let substlist = make_subst idsl' argsl in
       let subst = make_subst ids' args in
-      in_not top loc env (subst,substlist) extrargs c
+      in_not top loc scopes (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))
+      in_pat top (None,find_delimiters_scope loc key::snd scopes) e
+    | CPatPrim (loc,p) -> fst (Notation.interp_prim_token_cases_pattern_expr loc (test_kind false) p scopes)
     | CPatAtom (loc, Some id) ->
       begin
-	match drop_syndef top env id [] with
+	match drop_syndef top scopes 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
+      RCPatOr (loc,List.map (in_pat top scopes) pl)
+    | CPatCast _ ->
+      assert false
+  and in_pat_sc scopes x = in_pat false (x,snd scopes)
+  and in_not top loc scopes (subst,substlist as fullsubst) args = function
     | NVar id ->
       let () = assert (List.is_empty args) in
       begin
@@ -1201,8 +1338,7 @@ let drop_notations_pattern looked_for =
 	(* 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
+	  in_pat top (scopt,subscopes@snd scopes) 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)
@@ -1210,23 +1346,23 @@ let drop_notations_pattern looked_for =
     | 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)
+      RCPatCstr (loc, g, [], List.map2 (in_pat_sc scopes) 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) ->
+		 List.map2 (fun x -> in_not false loc (x,snd scopes) fullsubst []) argscs1 pl @
+		 List.map (in_pat false scopes) args, [])
+    | NList (x,y,iter,terminator,lassoc) ->
       if not (List.is_empty args) then user_err_loc
         (loc,"",strbrk "Application of arguments to a recursive notation not supported in patterns.");
       (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
+         let termin = in_not top loc scopes 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
+           let nsubst = Id.Map.add y (a, (scopt, subscopes)) subst in
+           let u = in_not false loc scopes (nsubst, substlist) [] iter in
            subst_pat_iterator ldots_var t u)
            (if lassoc then List.rev l else l) termin
        with Not_found ->
@@ -1249,7 +1385,7 @@ let rec intern_pat genv aliases pat =
       let aliases' = merge_aliases aliases id in
       intern_pat genv aliases' p
     | RCPatCstr (loc, head, expl_pl, pl) ->
-      if !oldfashion_patterns then
+      if !asymmetric_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 =
@@ -1274,29 +1410,65 @@ let rec intern_pat genv aliases pat =
       check_or_pat_variables loc ids (List.tl idsl);
       (ids,List.flatten pl')
 
-let intern_cases_pattern genv env aliases pat =
+(* [check_no_patcast p] raises an error if [p] contains a cast. This code is a
+   bit ad-hoc, and is due to current restrictions on casts in patterns. We
+   support them only in local binders and only at top level. In fact, they are
+   currently eliminated by the parser. The only reason why they are in the
+   [cases_pattern_expr] type is that the parser needs to factor the "(c : t)"
+   notation with user defined notations (such as the pair). In the long term, we
+   will try to support such casts everywhere, and use them to print the domains
+   of lambdas in the encoding of match in constr. We put this check here and not
+   in the parser because it would require to duplicate the levels of the
+   [pattern] rule. *)
+let rec check_no_patcast = function
+  | CPatCast (loc,_,_) ->
+     CErrors.user_err_loc (loc, "check_no_patcast",
+                           Pp.strbrk "Casts are not supported here.")
+  | CPatDelimiters(_,_,p)
+  | CPatAlias(_,p,_) -> check_no_patcast p
+  | CPatCstr(_,_,opl,pl) ->
+     Option.iter (List.iter check_no_patcast) opl;
+     List.iter check_no_patcast pl
+  | CPatOr(_,pl) ->
+     List.iter check_no_patcast pl
+  | CPatNotation(_,_,subst,pl) ->
+     check_no_patcast_subst subst;
+     List.iter check_no_patcast pl
+  | CPatRecord(_,prl) ->
+     List.iter (fun (_,p) -> check_no_patcast p) prl
+  | CPatAtom _ | CPatPrim _ -> ()
+
+and check_no_patcast_subst (pl,pll) =
+  List.iter check_no_patcast pl;
+  List.iter (List.iter check_no_patcast) pll
+
+let intern_cases_pattern genv scopes aliases pat =
+  check_no_patcast pat;
   intern_pat genv aliases
-    (drop_notations_pattern (function ConstructRef _ -> () | _ -> raise Not_found) env pat)
+    (drop_notations_pattern (function ConstructRef _ -> () | _ -> raise Not_found) scopes pat)
 
-let intern_ind_pattern genv env pat =
+let _ =
+  intern_cases_pattern_fwd :=
+    fun scopes p -> intern_cases_pattern (Global.env ()) scopes empty_alias p
+
+let intern_ind_pattern genv scopes pat =
+  check_no_patcast pat;
   let no_not =
     try
-      drop_notations_pattern (function (IndRef _ | ConstructRef _) -> () | _ -> raise Not_found) env pat
+      drop_notations_pattern (function (IndRef _ | ConstructRef _) -> () | _ -> raise Not_found) scopes pat
     with InternalizationError(loc,NotAConstructor _) -> error_bad_inductive_type loc
- in
+  in
   match no_not with
-    | RCPatCstr (loc, head,expl_pl, pl) ->
-      let c = (function IndRef ind -> ind
-	|_ -> error_bad_inductive_type loc) head in
+    | 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)
+       | _,[_,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)
 
 (**********************************************************************)
@@ -1362,7 +1534,7 @@ let extract_explicit_arg imps args =
 (**********************************************************************)
 (* Main loop                                                          *)
 
-let internalize globalenv env allow_patvar lvar c =
+let internalize globalenv env allow_patvar (_, ntnvars as lvar) c =
   let rec intern env = function
     | CRef (ref,us) as x ->
 	let (c,imp,subscopes,l),_ =
@@ -1383,10 +1555,11 @@ let internalize globalenv env allow_patvar lvar c =
           (fun (id,(n,order),bl,ty,_) ->
 	     let intern_ro_arg f =
 	       let before, after = split_at_annot bl n in
-	       let (env',rbefore) =
-		 List.fold_left intern_local_binder (env,[]) before in
+	       let (env',rbefore) = List.fold_left intern_local_binder (env,[]) before in
+               let rbefore = List.map (function BDRawDef a -> a | BDPattern _ -> assert false) rbefore in
 	       let ro = f (intern env') in
-	       let n' = Option.map (fun _ -> List.length (List.filter (fun (_,(_,_,b,_)) -> (* remove let-ins *) b = None) rbefore)) n in
+	       let n' = Option.map (fun _ -> List.count (fun (_,(_,_,b,_)) -> (* remove let-ins *) b = None) rbefore) n in
+               let rbefore = List.map (fun a -> BDRawDef a) rbefore in
 		 n', ro, List.fold_left intern_local_binder (env',rbefore) after
 	     in
 	     let n, ro, (env',rbl) =
@@ -1398,12 +1571,18 @@ let internalize globalenv env allow_patvar lvar c =
 	       | CMeasureRec (m,r) ->
 		   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 bl =
+               List.rev_map
+                 (function
+                  | BDRawDef a -> a
+                  | BDPattern (loc,_,_,_,_) ->
+                      Loc.raise loc (Stream.Error "pattern with quote not allowed after fix")) rbl in
+	       ((n, ro), bl, 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 (_,bli,tyi,_) = idl_temp.(i) 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)
+					       push_name_env ntnvars (impls_type_list ~args:fix_args tyi)
 					    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
@@ -1422,15 +1601,15 @@ let internalize globalenv env allow_patvar lvar c =
 	in
         let idl_tmp = Array.map
           (fun ((loc,id),bl,ty,_) ->
-            let (env',rbl) =
-              List.fold_left intern_local_binder (env,[]) bl in
+            let (env',rbl) = List.fold_left intern_local_binder (env,[]) bl in
+            let rbl = List.map (function BDRawDef a -> a | BDPattern _ -> assert false) rbl 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 (bli,tyi,_) = idl_tmp.(i) 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)
+	       push_name_env ntnvars (impls_type_list ~args:cofix_args tyi)
 					    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,
@@ -1449,15 +1628,15 @@ let internalize globalenv env allow_patvar lvar c =
     | CLetIn (loc,na,c1,c2) ->
 	let inc1 = intern (reset_tmp_scope env) c1 in
 	GLetIn (loc, snd na, inc1,
-          intern (push_name_env lvar (impls_term_list inc1) env na) c2)
+          intern (push_name_env ntnvars (impls_term_list inc1) env na) c2)
     | CNotation (loc,"- _",([CPrim (_,Numeral p)],[],[]))
 	when Bigint.is_strictly_pos p ->
 	intern env (CPrim (loc,Numeral (Bigint.neg p)))
     | CNotation (_,"( _ )",([a],[],[])) -> intern env a
     | CNotation (loc,ntn,args) ->
-        intern_notation intern env lvar loc ntn args
+        intern_notation intern env ntnvars loc ntn args
     | CGeneralization (loc,b,a,c) ->
-        intern_generalization intern env lvar loc b a c
+        intern_generalization intern env ntnvars loc b a c
     | CPrim (loc, p) ->
 	fst (Notation.interp_prim_token loc p (env.tmp_scope,env.scopes))
     | CDelimiters (loc, key, e) ->
@@ -1485,20 +1664,22 @@ let internalize globalenv env allow_patvar lvar c =
 	       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
+                let c = intern_notation intern env ntnvars loc ntn ([],[],[]) in
                 let x, impl, scopes, l = find_appl_head_data c in
 		  (x,impl,scopes,l), args
             | x -> (intern env f,[],[],[]), args in
           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 (Evar_kinds.QuestionMark (Evar_kinds.Define true)), Misctypes.IntroAnonymous, None) :: l)
-	in
-	begin
-	  match cargs with
+    | CRecord (loc, fs) ->
+       let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in
+       let fields =
+	 sort_fields ~complete:true loc fs
+	             (fun _idx -> CHole (loc, Some (Evar_kinds.QuestionMark st),
+                                                 Misctypes.IntroAnonymous, None))
+       in
+       begin
+	  match fields with
 	    | None -> user_err_loc (loc, "intern", str"No constructor inference.")
 	    | Some (n, constrname, args) ->
 		let pars = List.make n (CHole (loc, None, Misctypes.IntroAnonymous, None)) in
@@ -1506,60 +1687,70 @@ let internalize globalenv env allow_patvar lvar c =
 	  intern env app
 	end
     | CCases (loc, sty, rtnpo, tms, eqns) ->
-      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 as_in_vars = List.fold_left (fun acc (_,na,inb) ->
+	  Option.fold_left (fun acc tt -> Id.Set.union (ids_of_cases_indtype tt) acc)
+            (Option.fold_left (fun acc (_,y) -> name_fold Id.Set.add y acc) 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 ntnvars (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) (* "=> _" *)]))
+	  | l ->
+             (* Build a return predicate by expansion of the patterns of the "in" clause *)
+             let thevars,thepats = List.split l in
+             let sub_rtn = (* Some (GSort (Loc.ghost,GType None)) *) None in
+             let sub_tms = List.map (fun id -> GVar (Loc.ghost,id),(Name id,None)) thevars (* "match v1,..,vn" *) in
+             let main_sub_eqn =
+               (Loc.ghost,[],thepats, (* "|p1,..,pn" *)
+		Option.cata (intern_type env')
+                  (GHole(Loc.ghost,Evar_kinds.CasesType false,Misctypes.IntroAnonymous,None))
+                  rtnpo) (* "=> P" if there were a return predicate P, and "=> _" otherwise *) in
+             let catch_all_sub_eqn =
+               if List.for_all (irrefutable globalenv) thepats then [] else
+                 [Loc.ghost,[],List.make (List.length thepats) (PatVar(Loc.ghost,Anonymous)), (* "|_,..,_" *)
+		  GHole(Loc.ghost,Evar_kinds.ImpossibleCase,Misctypes.IntroAnonymous,None)]   (* "=> _" *) in
+             Some (GCases(Loc.ghost,Term.RegularStyle,sub_rtn,sub_tms,main_sub_eqn::catch_all_sub_eqn))
 	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
 	(* "in" is None so no match to add *)
-        let ((b',(na',_)),_,_) = intern_case_item env' Id.Set.empty (b,(na,None)) in
+        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')
+	  let env'' = push_name_env ntnvars (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)
+                   intern (List.fold_left (push_name_env ntnvars (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',_)),_,_) = intern_case_item env' Id.Set.empty (c,(na,None)) in (* no "in" no match to ad too *)
+      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)
+          let env'' = push_name_env ntnvars (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, naming, solve) ->
         let k = match k with
-        | None -> Evar_kinds.QuestionMark (Evar_kinds.Define true)
+        | None ->
+           let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in
+           Evar_kinds.QuestionMark st
         | Some k -> k
         in
         let solve = match solve with
@@ -1598,12 +1789,11 @@ let internalize globalenv env allow_patvar lvar c =
   and intern_type env = intern (set_type_scope env)
 
   and intern_local_binder env bind =
-    intern_local_binder_aux intern lvar env bind
+    intern_local_binder_aux intern ntnvars 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} empty_alias) pl in
+    let idsl_pll = List.map (intern_cases_pattern globalenv (None,env.scopes) empty_alias) pl in
     check_number_of_pattern loc n pl;
     product_of_cases_patterns [] idsl_pll
 
@@ -1624,12 +1814,11 @@ let internalize globalenv env allow_patvar lvar c =
     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
-      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 forbidden_names_for_gen (tm,(na,t)) =
-    (*the "match" part *)
+  and intern_case_item env forbidden_names_for_gen (tm,na,t) =
+    (* the "match" part *)
     let tm' = intern env tm in
     (* the "as" part *)
     let extra_id,na = match tm', na with
@@ -1640,9 +1829,7 @@ let internalize globalenv env allow_patvar lvar c =
     (* 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 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 with_letin,(ind,l) = intern_ind_pattern globalenv (None,env.scopes) 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")])
@@ -1654,23 +1841,23 @@ let internalize globalenv env allow_patvar lvar c =
 	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
+	      | _,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 ->
+	      | LocalDef _ :: 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 ->
+	      | _::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 ->
+	      | (LocalAssum (cano_name,ty) | LocalDef (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
+	      | _ -> 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
@@ -1680,11 +1867,11 @@ let internalize globalenv env allow_patvar lvar c =
     (tm',(snd na,typ)), extra_id, match_td
 
   and iterate_prod loc2 env bk ty body nal =
-    let env, bl = intern_assumption intern lvar env nal bk ty in
+    let env, bl = intern_assumption intern ntnvars env nal bk ty in
     it_mkGProd loc2 bl (intern_type env body)
 
   and iterate_lam loc2 env bk ty body nal =
-    let env, bl = intern_assumption intern lvar env nal bk ty in
+    let env, bl = intern_assumption intern ntnvars env nal bk ty in
     it_mkGLambda loc2 bl (intern env body)
 
   and intern_impargs c env l subscopes args =
@@ -1726,7 +1913,7 @@ let internalize globalenv env allow_patvar lvar c =
     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 imp = select_impargs_size (List.length (List.filter (fun (_,x) -> x == None) l)) imp in
     let l = intern_impargs c env imp subscopes l in
       smart_gapp c loc l
 
@@ -1760,7 +1947,7 @@ let extract_ids env =
     Id.Set.empty
 
 let scope_of_type_kind = function
-  | IsType -> Some Notation.type_scope
+  | IsType -> Notation.current_type_scope_name ()
   | OfType typ -> compute_type_scope typ
   | WithoutTypeConstraint -> None
 
@@ -1784,9 +1971,7 @@ 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} empty_alias patt
+    intern_cases_pattern globalenv (None,[]) empty_alias patt
   with
       InternalizationError (loc,e) ->
 	user_err_loc (loc,"internalize",explain_internalization_error e)
@@ -1857,18 +2042,19 @@ let intern_constr_pattern env ?(as_type=false) ?(ltacvars=empty_ltac_sign) c =
 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 = Id.Map.map (fun typ -> (ref None, typ)) nenv.ninterp_var_type in
+  let vl = Id.Map.map (fun typ -> (ref true, 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 (empty_ltac_sign, vl) a in
   (* Translate and check that [c] has all its free variables bound in [vars] *)
-  let a = notation_constr_of_glob_constr nenv c in
+  let a, reversible = 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 = Id.Map.map (fun (sc, typ) -> (out_scope !sc, typ)) vl in
+  let vars = Id.Map.map (fun (isonlybinding, sc, typ) ->
+    (!isonlybinding, out_scope !sc, typ)) vl in
   (* Returns [a] and the ordered list of variables with their scopes *)
-  vars, a
+  vars, a, reversible
 
 (* Interpret binders and contexts  *)
 
@@ -1891,7 +2077,16 @@ 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 env lvar) lvar)
+	    (fun (lenv, bl) b ->
+               let bl = List.map (fun a -> BDRawDef a) bl in
+	       let (env, bl) = intern_local_binder_aux ~global_level (my_intern_constr env lvar) Id.Map.empty (lenv, bl) b in
+               let bl =
+                 List.map
+                   (function
+                    | BDRawDef a -> a
+                    | BDPattern (loc,_,_,_,_) ->
+                        Loc.raise loc (Stream.Error "pattern with quote not allowed here")) bl in
+	       (env, bl))
 	    ({ids = extract_ids env; unb = false;
 	      tmp_scope = None; scopes = []; impls = impl_env}, []) binders in
   (lenv.impls, List.map snd bl)
@@ -1902,12 +2097,14 @@ let interp_rawcontext_evars env evdref k bl =
   let (env, par, _, impls) =
     List.fold_left
       (fun (env,params,n,impls) (na, k, b, t) ->
+       let t' =
+	 if Option.is_empty b then locate_if_hole (loc_of_glob_constr t) na t
+	 else t
+       in
+       let t = understand_tcc_evars env evdref ~expected_type:IsType t' in
 	match b with
 	    None ->
-	      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 d = LocalAssum (na,t) in
 	      let impls =
 		if k == Implicit then
 		  let na = match na with Name n -> Some n | Anonymous -> None in
@@ -1916,8 +2113,8 @@ let interp_rawcontext_evars env evdref k bl =
 	      in
 		(push_rel d env, d::params, succ n, impls)
 	  | Some b ->
-	      let c = understand_judgment_tcc env evdref b in
-	      let d = (na, Some c.uj_val, c.uj_type) in
+	      let c = understand_tcc_evars env evdref ~expected_type:(OfType t) b in
+	      let d = LocalDef (na, c, t) in
 		(push_rel d env, d::params, n, impls))
       (env,[],k+1,[]) (List.rev bl)
   in (env, par), impls
diff --git a/interp/constrintern.mli b/interp/constrintern.mli
index 22cf910b..61e7c6f5 100644
--- a/interp/constrintern.mli
+++ b/interp/constrintern.mli
@@ -8,7 +8,6 @@
 
 open Names
 open Term
-open Context
 open Evd
 open Environ
 open Libnames
@@ -161,7 +160,7 @@ val interp_binder_evars : env -> evar_map ref -> Name.t -> constr_expr -> types
 val interp_context_evars :
   ?global_level:bool -> ?impl_env:internalization_env -> ?shift:int ->
   env -> evar_map ref -> local_binder list ->
-  internalization_env * ((env * rel_context) * Impargs.manual_implicits)
+  internalization_env * ((env * Context.Rel.t) * 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) -> *)
@@ -178,7 +177,7 @@ val interp_context_evars :
 
 val locate_reference :  Libnames.qualid -> Globnames.global_reference
 val is_global : Id.t -> bool
-val construct_reference : named_context -> Id.t -> constr
+val construct_reference : Context.Named.t -> Id.t -> constr
 val global_reference : Id.t -> constr
 val global_reference_in_absolute_module : DirPath.t -> Id.t -> constr
 
@@ -186,8 +185,8 @@ val global_reference_in_absolute_module : DirPath.t -> Id.t -> constr
     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
+  (bool * subscopes * notation_var_internalization_type) Id.Map.t *
+  notation_constr * reversibility_flag
 
 (** Globalization options *)
 val parsing_explicit : bool ref
diff --git a/interp/coqlib.ml b/interp/coqlib.ml
index 9e517381..588637b7 100644
--- a/interp/coqlib.ml
+++ b/interp/coqlib.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Pp
 open Names
@@ -87,7 +87,7 @@ let check_required_library d =
 *)
 (* or failing ...*)
       errorlabstrm "Coqlib.check_required_library"
-        (str "Library " ++ str (DirPath.to_string dir) ++ str " has to be required first.")
+        (str "Library " ++ pr_dirpath dir ++ str " has to be required first.")
 
 (************************************************************************)
 (* Specific Coq objects *)
diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml
index 0d9d021c..b020f894 100644
--- a/interp/dumpglob.ml
+++ b/interp/dumpglob.ml
@@ -45,10 +45,10 @@ let dump_string s =
   if dump () && !glob_output != Feedback then 
     Pervasives.output_string !glob_file s
 
-let start_dump_glob vfile =
+let start_dump_glob ~vfile ~vofile =
   match !glob_output with
   | MultFiles ->
-      open_glob_file (Filename.chop_extension vfile ^ ".glob");
+      open_glob_file (Filename.chop_extension vofile ^ ".glob");
       output_string !glob_file "DIGEST ";
       output_string !glob_file (Digest.to_hex (Digest.file vfile));
       output_char !glob_file '\n'
@@ -127,9 +127,10 @@ let type_of_global_ref gr =
     | Globnames.ConstructRef _ -> "constr"
 
 let remove_sections dir =
-  if Libnames.is_dirpath_prefix_of dir (Lib.cwd ()) then
+  let cwd = Lib.cwd_except_section () in
+  if Libnames.is_dirpath_prefix_of cwd dir then
     (* Not yet (fully) discharged *)
-    Libnames.pop_dirpath_n (Lib.sections_depth ()) (Lib.cwd ())
+    cwd
   else
     (* Theorem/Lemma outside its outer section of definition *)
     dir
@@ -141,7 +142,7 @@ let interval loc =
 let dump_ref loc filepath modpath ident ty =
   match !glob_output with
   | Feedback ->
-    Pp.feedback (Feedback.GlobRef (loc, filepath, modpath, ident, ty))
+    Feedback.feedback (Feedback.GlobRef (loc, filepath, modpath, ident, ty))
   | NoGlob -> ()
   | _ when not (Loc.is_ghost loc) ->
     let bl,el = interval loc in
@@ -172,7 +173,7 @@ let cook_notation df sc =
   (* - all single quotes in terminal tokens are doubled                       *)
   (* - characters < 32 are represented by '^A, '^B, '^C, etc                  *)
   (* The output is decoded in function Index.prepare_entry of coqdoc          *)
-  let ntn = String.make (String.length df * 3) '_' in
+  let ntn = String.make (String.length df * 5) '_' in
   let j = ref 0 in
   let l = String.length df - 1 in
   let i = ref 0 in
@@ -240,7 +241,7 @@ 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))
+    Feedback.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)
@@ -248,7 +249,7 @@ let dump_def ty loc 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 =
+let dump_constraint (((loc, n),_), _, _) sec ty =
   match n with
     | Names.Name id -> dump_definition (loc, id) sec ty
     | Names.Anonymous -> ()
diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli
index a7c79911..e84a6405 100644
--- a/interp/dumpglob.mli
+++ b/interp/dumpglob.mli
@@ -9,7 +9,7 @@
 val open_glob_file : string -> unit
 val close_glob_file : unit -> unit
 
-val start_dump_glob : string -> unit
+val start_dump_glob : vfile:string -> vofile:string -> unit
 val end_dump_glob : unit -> unit
 
 val dump : unit -> bool
diff --git a/interp/genintern.ml b/interp/genintern.ml
index 47b71735..d6bfd347 100644
--- a/interp/genintern.ml
+++ b/interp/genintern.ml
@@ -37,20 +37,16 @@ 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
+let generic_intern ist (GenArg (Rawwit wit, v)) =
+  let (ist, v) = intern wit ist v in
+  (ist, in_gen (glbwit wit) 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 generic_substitute subs (GenArg (Glbwit wit, v)) =
+  in_gen (glbwit wit) (substitute wit subs v)
 
 let () = Hook.set Detyping.subst_genarg_hook generic_substitute
diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml
index 391c600e..10cfbe58 100644
--- a/interp/implicit_quantifiers.ml
+++ b/interp/implicit_quantifiers.ml
@@ -9,7 +9,7 @@
 (*i*)
 open Names
 open Decl_kinds
-open Errors
+open CErrors
 open Util
 open Glob_term
 open Constrexpr
@@ -20,6 +20,7 @@ open Pp
 open Libobject
 open Nameops
 open Misctypes
+open Context.Rel.Declaration
 (*i*)
 
 let generalizable_table = Summary.ref Id.Pred.empty ~name:"generalizable-ident"
@@ -111,6 +112,7 @@ let free_vars_of_binders ?(bound=Id.Set.empty) l (binders : local_binder list) =
 	let l' = free_vars_of_constr_expr c ~bound:bdvars l in
 	  aux (Id.Set.union (ids_of_list bound) bdvars) l' tl
 
+    | LocalPattern _ :: tl -> assert false
     | [] -> bdvars, l
   in aux bound l binders
 
@@ -196,7 +198,7 @@ let combine_params avoid fn applied needed =
     List.partition
       (function
 	  (t, Some (loc, ExplByName id)) ->
-            let is_id (_, (na, _, _)) = match na with
+            let is_id (_, decl) = match get_name decl with
             | Name id' -> Id.equal id id'
             | Anonymous -> false
             in
@@ -209,22 +211,22 @@ let combine_params avoid fn applied needed =
     (fun x -> match x with (t, Some (loc, ExplByName id)) -> id, t | _ -> assert false)
     named
   in
-  let is_unset (_, (_, b, _)) = match b with
-  | None -> true
-  | Some _ -> false
+  let is_unset (_, decl) = match decl with
+  | LocalAssum _ -> true
+  | LocalDef _ -> 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 Id.List.mem_assoc id named ->
+      | app, (_, (LocalAssum (Name id, _) | LocalDef (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 ->
+      | (x, None) :: app, (None, (LocalAssum (Name id, _) | LocalDef (Name id, _, _))) :: need ->
 	  aux (x :: ids) avoid app need
 
-      | _, (Some cl, (_, _, _) as d) :: need ->
+      | _, (Some cl, _ as d) :: need ->
 	  let t', avoid' = fn avoid d in
 	    aux (t' :: ids) avoid' app need
 
@@ -239,8 +241,8 @@ let combine_params avoid fn applied needed =
   in aux [] avoid applied needed
 
 let combine_params_freevar =
-  fun avoid (_, (na, _, _)) ->
-    let id' = next_name_away_from na avoid in
+  fun avoid (_, decl) ->
+    let id' = next_name_away_from (get_name decl) avoid in
       (CRef (Ident (Loc.ghost, id'),None), Id.Set.add id' avoid)
 
 let destClassApp cl =
@@ -309,7 +311,7 @@ let implicits_of_glob_constr ?(with_products=true) l =
 	  else
             let () = match bk with
             | Implicit ->
-	       msg_warning (strbrk "Ignoring implicit status of product binder " ++ 
+	       Feedback.msg_warning (strbrk "Ignoring implicit status of product binder " ++ 
 			      pr_name na ++ strbrk " and following binders")
             | _ -> ()
             in []
diff --git a/interp/implicit_quantifiers.mli b/interp/implicit_quantifiers.mli
index b226bfa0..d0327e50 100644
--- a/interp/implicit_quantifiers.mli
+++ b/interp/implicit_quantifiers.mli
@@ -38,10 +38,10 @@ 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 :
-  Id.Set.t -> (global_reference * bool) option * (Name.t * Term.constr option * Term.types) ->
+  Id.Set.t -> (global_reference * bool) option * Context.Rel.Declaration.t ->
   Constrexpr.constr_expr * Id.Set.t
 
 val implicit_application : Id.Set.t -> ?allow_partial:bool ->
-  (Id.Set.t -> (global_reference * bool) option * (Name.t * Term.constr option * Term.types) ->
+  (Id.Set.t -> (global_reference * bool) option * Context.Rel.Declaration.t ->
     Constrexpr.constr_expr * Id.Set.t) ->
   constr_expr -> constr_expr * Id.Set.t
diff --git a/interp/notation.ml b/interp/notation.ml
index 5c10e0af..389a1c9d 100644
--- a/interp/notation.ml
+++ b/interp/notation.ml
@@ -7,13 +7,12 @@
 (************************************************************************)
 
 (*i*)
-open Errors
+open CErrors
 open Util
 open Pp
 open Bigint
 open Names
 open Term
-open Nametab
 open Libnames
 open Globnames
 open Constrexpr
@@ -45,8 +44,14 @@ type level = precedence * tolerability list
 type delimiters = string
 type notation_location = (DirPath.t * DirPath.t) * string
 
+type notation_data = {
+  not_interp : interpretation;
+  not_location : notation_location;
+  not_onlyprinting : bool;
+}
+
 type scope = {
-  notations: (interpretation * notation_location) String.Map.t;
+  notations: notation_data String.Map.t;
   delimiters: delimiters option
 }
 
@@ -65,11 +70,9 @@ let empty_scope = {
 }
 
 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 := String.Map.add default_scope empty_scope !scope_map;
-  scope_map := String.Map.add type_scope empty_scope !scope_map
+  scope_map := String.Map.add default_scope empty_scope !scope_map
 
 (**********************************************************************)
 (* Operations on scopes *)
@@ -187,7 +190,8 @@ let declare_delimiters scope key =
     | None -> scope_map := String.Map.add scope newsc !scope_map
     | Some oldkey when String.equal oldkey key -> ()
     | Some oldkey ->
-	msg_warning
+        (** FIXME: implement multikey scopes? *)
+	Flags.if_verbose Feedback.msg_info
 	  (str "Overwriting previous delimiting key " ++ str oldkey ++ str " in scope " ++ str scope);
 	scope_map := String.Map.add scope newsc !scope_map
   end;
@@ -195,7 +199,7 @@ let declare_delimiters scope key =
     let oldscope = String.Map.find key !delimiters_map in
     if String.equal oldscope scope then ()
     else begin
-      msg_warning (str "Hiding binding of key " ++ str key ++ str " to " ++ str oldscope);
+      Flags.if_verbose Feedback.msg_info (str "Hiding binding of key " ++ str key ++ str " to " ++ str oldscope);
       delimiters_map := String.Map.add key scope !delimiters_map
     end
   with Not_found -> delimiters_map := String.Map.add key scope !delimiters_map
@@ -204,7 +208,7 @@ let remove_delimiters scope =
   let sc = find_scope scope in
   let newsc = { sc with delimiters = None } in
   match sc.delimiters with
-    | None -> msg_warning (str "No bound key for scope " ++ str scope ++ str ".")
+    | None -> CErrors.errorlabstrm "" (str "No bound key for scope " ++ str scope ++ str ".")
     | Some key ->
        scope_map := String.Map.add scope newsc !scope_map;
        try
@@ -314,7 +318,9 @@ let declare_prim_token_interpreter sc interp (patl,uninterp,b) =
     patl
 
 let mkNumeral n = Numeral n
-let mkString s = String s
+let mkString = function
+| None -> None
+| Some s -> if Unicode.is_utf8 s then Some (String s) else None
 
 let delay dir int loc x = (dir, (fun () -> int loc x))
 
@@ -326,7 +332,7 @@ let declare_numeral_interpreter sc dir interp (patl,uninterp,inpat) =
 let declare_string_interpreter sc dir interp (patl,uninterp,inpat) =
   declare_prim_token_interpreter sc
     (fun cont loc -> function String s -> delay dir interp loc s | p -> cont loc p)
-    (patl, (fun r -> Option.map mkString (uninterp r)), inpat)
+    (patl, (fun r -> mkString (uninterp r)), inpat)
 
 let check_required_module loc sc (sp,d) =
   try let _ = Nametab.global_of_path sp in ()
@@ -381,17 +387,28 @@ let level_of_notation ntn =
 
 (* The mapping between notations and their interpretation *)
 
-let declare_notation_interpretation ntn scopt pat df =
+let warn_notation_overridden =
+  CWarnings.create ~name:"notation-overridden" ~category:"parsing"
+                   (fun (ntn,which_scope) ->
+                    str "Notation" ++ spc () ++ str ntn ++ spc ()
+                    ++ strbrk "was already used" ++ which_scope)
+
+let declare_notation_interpretation ntn scopt pat df ~onlyprint =
   let scope = match scopt with Some s -> s | None -> default_scope in
   let sc = find_scope scope in
   let () =
     if String.Map.mem ntn sc.notations then
     let which_scope = match scopt with
     | None -> mt ()
-    | Some _ -> str " in scope " ++ str scope in
-    msg_warning (str "Notation " ++ str ntn ++ str " was already used" ++ which_scope)
+    | Some _ -> spc () ++ strbrk "in scope" ++ spc () ++ str scope in
+    warn_notation_overridden (ntn,which_scope)
   in
-  let sc = { sc with notations = String.Map.add ntn (pat,df) sc.notations } in
+  let notdata = {
+    not_interp = pat;
+    not_location = df;
+    not_onlyprinting = onlyprint;
+  } in
+  let sc = { sc with notations = String.Map.add ntn notdata 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
@@ -416,7 +433,9 @@ let rec find_interpretation ntn find = function
       find_interpretation ntn find scopes
 
 let find_notation ntn sc =
-  String.Map.find ntn (find_scope sc).notations
+  let n = String.Map.find ntn (find_scope sc).notations in
+  let () = if n.not_onlyprinting then raise Not_found in
+  (n.not_interp, n.not_location)
 
 let notation_of_prim_token = function
   | Numeral n when is_pos_or_zero n -> to_string n
@@ -529,26 +548,25 @@ let pair_eq f g (x1, y1) (x2, y2) = f x1 x2 && g y1 y2
 
 let ntpe_eq t1 t2 = match t1, t2 with
 | NtnTypeConstr, NtnTypeConstr -> true
+| NtnTypeOnlyBinder, NtnTypeOnlyBinder -> true
 | NtnTypeConstrList, NtnTypeConstrList -> true
 | NtnTypeBinderList, NtnTypeBinderList -> true
-| (NtnTypeConstr | NtnTypeConstrList | NtnTypeBinderList), _ -> false
+| (NtnTypeConstr | NtnTypeOnlyBinder | NtnTypeConstrList | NtnTypeBinderList), _ -> false
 
-
-let vars_eq (id1, (sc1, tp1)) (id2, (sc2, tp2)) =
-  Id.equal id1 id2 &&
+let var_attributes_eq (_, (sc1, tp1)) (_, (sc2, tp2)) =
   pair_eq (Option.equal String.equal) (List.equal String.equal) sc1 sc2 &&
   ntpe_eq tp1 tp2
 
 let interpretation_eq (vars1, t1) (vars2, t2) =
-  List.equal vars_eq vars1 vars2 &&
-  Notation_ops.eq_notation_constr t1 t2
+  List.equal var_attributes_eq vars1 vars2 &&
+  Notation_ops.eq_notation_constr (List.map fst vars1, List.map fst vars2) t1 t2
 
 let exists_notation_in_scope scopt ntn r =
   let scope = match scopt with Some s -> s | None -> default_scope in
   try
     let sc = String.Map.find scope !scope_map in
-    let (r',_) = String.Map.find ntn sc.notations in
-    interpretation_eq r' r
+    let n = String.Map.find ntn sc.notations in
+    interpretation_eq n.not_interp r
   with Not_found -> false
 
 let isNVar_or_NHole = function NVar _ | NHole _ -> true | _ -> false
@@ -556,23 +574,16 @@ let isNVar_or_NHole = function NVar _ | NHole _ -> true | _ -> false
 (**********************************************************************)
 (* Mapping classes to scopes *)
 
-type scope_class = ScopeRef of global_reference | ScopeSort
+open Classops
 
-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
+type scope_class = cl_typ
 
-let scope_class_of_reference x = ScopeRef x
+let scope_class_compare : scope_class -> scope_class -> int =
+  cl_typ_ord
 
 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 (cl,_,_) = find_class_type Evd.empty t in
+  cl
 
 module ScopeClassOrd =
 struct
@@ -583,7 +594,7 @@ end
 module ScopeClassMap = Map.Make(ScopeClassOrd)
 
 let initial_scope_class_map : scope_name ScopeClassMap.t =
-  ScopeClassMap.add ScopeSort "type_scope" ScopeClassMap.empty
+  ScopeClassMap.empty
 
 let scope_class_map = ref initial_scope_class_map
 
@@ -617,8 +628,11 @@ let compute_arguments_scope t = fst (compute_arguments_scope_full t)
 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))
+let current_type_scope_name () =
+   find_scope_class_opt (Some CL_SORT)
+
+let scope_class_of_class (x : cl_typ) : scope_class =
+  x
 
 (** Updating a scope list, thanks to a list of argument classes
     and the current Bind Scope base. When some current scope
@@ -642,7 +656,7 @@ type arguments_scope_discharge_request =
   | ArgsScopeManual
   | ArgsScopeNoDischarge
 
-let load_arguments_scope _ (_,(_,r,scl,cls)) =
+let load_arguments_scope _ (_,(_,r,n,scl,cls)) =
   List.iter (Option.iter check_scope) scl;
   let initial_stamp = ScopeClassMap.empty in
   arguments_scope := Refmap.add r (scl,cls,initial_stamp) !arguments_scope
@@ -650,14 +664,10 @@ let load_arguments_scope _ (_,(_,r,scl,cls)) =
 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_scope_class subst cs =
+  try Some (subst_cl_typ subst cs) with Not_found -> None
 
-let subst_arguments_scope (subst,(req,r,scl,cls)) =
+let subst_arguments_scope (subst,(req,r,n,scl,cls)) =
   let r' = fst (subst_global subst r) in
   let subst_cl ocl = match ocl with
     | None -> ocl
@@ -666,34 +676,42 @@ let subst_arguments_scope (subst,(req,r,scl,cls)) =
         | Some cl'  as ocl' when cl' != cl -> ocl'
         | _ -> ocl in
   let cls' = List.smartmap subst_cl cls in
-  (ArgsScopeNoDischarge,r',scl,cls')
+  (ArgsScopeNoDischarge,r',n,scl,cls')
 
-let discharge_arguments_scope (_,(req,r,l,_)) =
+let discharge_arguments_scope (_,(req,r,n,l,_)) =
   if req == ArgsScopeNoDischarge || (isVarRef r && Lib.is_in_section r) then None
-  else Some (req,Lib.discharge_global r,l,[])
+  else
+    let n =
+      try
+        let vars = Lib.variable_section_segment_of_reference r in
+        List.length (List.filter (fun (_,_,b,_) -> b = None) vars)
+      with
+        Not_found (* Not a ref defined in this section *) -> 0 in
+    Some (req,Lib.discharge_global r,n,l,[])
 
-let classify_arguments_scope (req,_,_,_ as obj) =
+let classify_arguments_scope (req,_,_,_,_ as obj) =
   if req == ArgsScopeNoDischarge then Dispose else Substitute obj
 
-let rebuild_arguments_scope (req,r,l,_) =
+let rebuild_arguments_scope (req,r,n,l,_) =
   match req with
     | ArgsScopeNoDischarge -> assert false
     | ArgsScopeAuto ->
         let scs,cls = compute_arguments_scope_full (fst(Universes.type_of_global r)(*FIXME?*)) in
-	(req,r,scs,cls)
+	(req,r,List.length scs,scs,cls)
     | ArgsScopeManual ->
 	(* Add to the manually given scopes the one found automatically
            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)
+        let l',cls = compute_arguments_scope_full (Global.type_of_global_unsafe r) in
+	let l1 = List.firstn n l' in
+        let cls1 = List.firstn n cls in
+	(req,r,0,l1@l,cls1)
 
 type arguments_scope_obj =
     arguments_scope_discharge_request * global_reference *
-      scope_name option list * scope_class option list
+    (* Used to communicate information from discharge to rebuild *)
+    (* set to 0 otherwise *) int *
+    scope_name option list * scope_class option list
 
 let inArgumentsScope : arguments_scope_obj -> obj =
   declare_object {(default_object "ARGUMENTS-SCOPE") with
@@ -706,16 +724,15 @@ let inArgumentsScope : arguments_scope_obj -> obj =
 
 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_gen req r n (scl,cls) =
+  Lib.add_anonymous_leaf (inArgumentsScope (req,r,n,scl,cls))
 
 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
+  let req = if is_local local r then ArgsScopeNoDischarge else ArgsScopeManual in
+  (* We empty the list of argument classes to disable further scope
      re-computations and keep these manually given scopes. *)
-  declare_arguments_scope_gen req r (scl,[])
-
+  declare_arguments_scope_gen req r 0 (scl,[])
+                              
 let find_arguments_scope r =
   try
     let (scl,cls,stamp) = Refmap.find r !arguments_scope in
@@ -730,7 +747,8 @@ let find_arguments_scope r =
 
 let declare_ref_arguments_scope ref =
   let t = Global.type_of_global_unsafe ref in
-  declare_arguments_scope_gen ArgsScopeAuto ref (compute_arguments_scope_full t)
+  let (scs,cls as o) = compute_arguments_scope_full t in
+  declare_arguments_scope_gen ArgsScopeAuto ref (List.length scs) o
 
 
 (********************************)
@@ -788,9 +806,7 @@ let pr_delimiters_info = function
 let classes_of_scope sc =
   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_class = pr_class
 
 let pr_scope_classes sc =
   let l = classes_of_scope sc in
@@ -815,7 +831,7 @@ let pr_named_scope prglob scope sc =
   ++ fnl ()
   ++ pr_scope_classes scope
   ++ String.Map.fold
-       (fun ntn ((_,r),(_,df)) strm ->
+       (fun ntn { not_interp  = (_, r); not_location = (_, df) } strm ->
 	 pr_notation_info prglob df r ++ fnl () ++ strm)
        sc.notations (mt ())
 
@@ -859,7 +875,7 @@ let browse_notation strict ntn map =
   let l =
     String.Map.fold
       (fun scope_name sc ->
-	String.Map.fold (fun ntn ((_,r),df) l ->
+	String.Map.fold (fun ntn { not_interp  = (_, r); not_location = df } l ->
 	  if find ntn then (ntn,(scope_name,r,df))::l else l) sc.notations)
       map [] in
   List.sort (fun x y -> String.compare (fst x) (fst y)) l
@@ -925,7 +941,7 @@ let locate_notation prglob ntn scope =
 let collect_notation_in_scope scope sc known =
   assert (not (String.equal scope default_scope));
   String.Map.fold
-    (fun ntn ((_,r),(_,df)) (l,known as acc) ->
+    (fun ntn { not_interp  = (_, r); not_location = (_, df) } (l,known as acc) ->
       if String.List.mem ntn known then acc else ((df,r)::l,ntn::known))
     sc.notations ([],known)
 
@@ -941,7 +957,7 @@ let collect_notations stack =
       | SingleNotation ntn ->
 	  if String.List.mem ntn knownntn then (all,knownntn)
 	  else
-	    let ((_,r),(_,df)) =
+	    let { not_interp  = (_, r); not_location = (_, df) } =
 	      String.Map.find ntn (find_scope default_scope).notations in
 	    let all' = match all with
 	      | (s,lonelyntn)::rest when String.equal s default_scope ->
@@ -977,23 +993,30 @@ let pr_visibility prglob = function
 type unparsing_rule = unparsing list * precedence
 type extra_unparsing_rules = (string * string) list
 (* Concrete syntax for symbolic-extension table *)
-let printing_rules =
-  ref (String.Map.empty : (unparsing_rule * extra_unparsing_rules) String.Map.t)
+let notation_rules =
+  ref (String.Map.empty : (unparsing_rule * extra_unparsing_rules * notation_grammar) String.Map.t)
 
-let declare_notation_printing_rule ntn ~extra unpl =
-  printing_rules := String.Map.add ntn (unpl,extra) !printing_rules
+let declare_notation_rule ntn ~extra unpl gram =
+  notation_rules := String.Map.add ntn (unpl,extra,gram) !notation_rules
 
 let find_notation_printing_rule ntn =
-  try fst (String.Map.find ntn !printing_rules)
+  try pi1 (String.Map.find ntn !notation_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)
+  try pi2 (String.Map.find ntn !notation_rules)
   with Not_found -> []
+let find_notation_parsing_rules ntn =
+  try pi3 (String.Map.find ntn !notation_rules)
+  with Not_found -> anomaly (str "No parsing rule found for " ++ str ntn)
+
+let get_defined_notations () =
+  String.Set.elements @@ String.Map.domain !notation_rules
+
 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
+    notation_rules :=
+      let p, pp, gr = String.Map.find ntn !notation_rules in
+      String.Map.add ntn (p, (k,v) :: pp, gr) !notation_rules
   with Not_found ->
     user_err_loc (Loc.ghost,"add_notation_extra_printing_rule",
       str "No such Notation.")
@@ -1003,7 +1026,7 @@ let add_notation_extra_printing_rule ntn k v =
 
 let freeze _ =
  (!scope_map, !notation_level_map, !scope_stack, !arguments_scope,
-  !delimiters_map, !notations_key_table, !printing_rules,
+  !delimiters_map, !notations_key_table, !notation_rules,
   !scope_class_map)
 
 let unfreeze (scm,nlm,scs,asc,dlm,fkm,pprules,clsc) =
@@ -1013,7 +1036,7 @@ let unfreeze (scm,nlm,scs,asc,dlm,fkm,pprules,clsc) =
   delimiters_map := dlm;
   arguments_scope := asc;
   notations_key_table := fkm;
-  printing_rules := pprules;
+  notation_rules := pprules;
   scope_class_map := clsc
 
 let init () =
@@ -1021,7 +1044,7 @@ let init () =
   notation_level_map := String.Map.empty;
   delimiters_map := String.Map.empty;
   notations_key_table := KeyMap.empty;
-  printing_rules := String.Map.empty;
+  notation_rules := String.Map.empty;
   scope_class_map := initial_scope_class_map
 
 let _ =
@@ -1034,6 +1057,6 @@ let with_notation_protection f x =
   let fs = freeze false in
   try let a = f x in unfreeze fs; a
   with reraise ->
-    let reraise = Errors.push reraise in
+    let reraise = CErrors.push reraise in
     let () = unfreeze fs in
     iraise reraise
diff --git a/interp/notation.mli b/interp/notation.mli
index 7885814c..2e92a00a 100644
--- a/interp/notation.mli
+++ b/interp/notation.mli
@@ -29,7 +29,6 @@ type scopes (** = [scope_name list] *)
 
 type local_scopes = tmp_scope_name option * scope_name list
 
-val type_scope : scope_name
 val declare_scope : scope_name -> unit
 
 val current_scopes : unit -> scopes
@@ -110,7 +109,7 @@ type interp_rule =
   | SynDefRule of kernel_name
 
 val declare_notation_interpretation : notation -> scope_name option ->
-      interpretation -> notation_location -> unit
+      interpretation -> notation_location -> onlyprint:bool -> unit
 
 val declare_uninterpretation : interp_rule -> interpretation -> unit
 
@@ -153,7 +152,9 @@ val find_arguments_scope : global_reference -> scope_name option list
 
 type scope_class
 
-val scope_class_of_reference : global_reference -> scope_class
+(** Comparison of scope_class *)
+val scope_class_compare : scope_class -> scope_class -> int
+
 val subst_scope_class :
   Mod_subst.substitution -> scope_class -> scope_class option
 
@@ -162,7 +163,11 @@ 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
+
+(** Get the current scope bound to Sortclass, if it exists *)
+val current_type_scope_name : unit -> scope_name option
+
+val scope_class_of_class : Classops.cl_typ -> scope_class
 
 (** Building notation key *)
 
@@ -191,12 +196,16 @@ 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
 type extra_unparsing_rules = (string * string) list
-val declare_notation_printing_rule :
-  notation -> extra:extra_unparsing_rules -> unparsing_rule -> unit
+val declare_notation_rule :
+  notation -> extra:extra_unparsing_rules -> unparsing_rule -> notation_grammar -> unit
 val find_notation_printing_rule : notation -> unparsing_rule
 val find_notation_extra_printing_rules : notation -> extra_unparsing_rules
+val find_notation_parsing_rules : notation -> notation_grammar
 val add_notation_extra_printing_rule : notation -> string -> string -> unit
 
+(** Returns notations with defined parsing/printing rules *)
+val get_defined_notations : unit -> notation list
+
 (** Rem: printing rules for primitive token are canonical *)
 
 val with_notation_protection : ('a -> 'b) -> 'a -> 'b
diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml
index 51dfadac..0c5393cf 100644
--- a/interp/notation_ops.ml
+++ b/interp/notation_ops.ml
@@ -7,23 +7,111 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
 open Globnames
+open Decl_kinds
 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     *)
+(* Utilities                                                          *)
+
+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_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with
+| NRef gr1, NRef gr2 -> eq_gr gr1 gr2
+| NVar id1, NVar id2 -> Int.equal (List.index Id.equal id1 vars1) (List.index Id.equal id2 vars2)
+| NApp (t1, a1), NApp (t2, a2) ->
+  (eq_notation_constr vars) t1 t2 && List.equal (eq_notation_constr vars) a1 a2
+| NHole (_, _, _), NHole (_, _, _) -> true (** FIXME? *)
+| NList (i1, j1, t1, u1, b1), NList (i2, j2, t2, u2, b2) ->
+  Id.equal i1 i2 && Id.equal j1 j2 && (eq_notation_constr vars) t1 t2 &&
+  (eq_notation_constr vars) u1 u2 && b1 == b2
+| NLambda (na1, t1, u1), NLambda (na2, t2, u2) ->
+  Name.equal na1 na2 && (eq_notation_constr vars) t1 t2 && (eq_notation_constr vars) u1 u2
+| NProd (na1, t1, u1), NProd (na2, t2, u2) ->
+  Name.equal na1 na2 && (eq_notation_constr vars) t1 t2 && (eq_notation_constr vars) u1 u2
+| NBinderList (i1, j1, t1, u1), NBinderList (i2, j2, t2, u2) ->
+  Id.equal i1 i2 && Id.equal j1 j2 && (eq_notation_constr vars) t1 t2 &&
+  (eq_notation_constr vars) u1 u2
+| NLetIn (na1, t1, u1), NLetIn (na2, t2, u2) ->
+  Name.equal na1 na2 && (eq_notation_constr vars) t1 t2 && (eq_notation_constr vars) u1 u2
+| NCases (_, o1, r1, p1), NCases (_, o2, r2, p2) -> (** FIXME? *)
+  let eqpat (p1, t1) (p2, t2) =
+    List.equal cases_pattern_eq p1 p2 &&
+    (eq_notation_constr vars) t1 t2
+  in
+  let eqf (t1, (na1, o1)) (t2, (na2, o2)) =
+    let eq (i1, n1) (i2, n2) = eq_ind i1 i2 && List.equal Name.equal n1 n2 in
+    (eq_notation_constr vars) t1 t2 && Name.equal na1 na2 && Option.equal eq o1 o2
+  in
+  Option.equal (eq_notation_constr vars) o1 o2 &&
+  List.equal eqf r1 r2 &&
+  List.equal eqpat p1 p2
+| NLetTuple (nas1, (na1, o1), t1, u1), NLetTuple (nas2, (na2, o2), t2, u2) ->
+  List.equal Name.equal nas1 nas2 &&
+  Name.equal na1 na2 &&
+  Option.equal (eq_notation_constr vars) o1 o2 &&
+  (eq_notation_constr vars) t1 t2 &&
+  (eq_notation_constr vars) u1 u2
+| NIf (t1, (na1, o1), u1, r1), NIf (t2, (na2, o2), u2, r2) ->
+  (eq_notation_constr vars) t1 t2 &&
+  Name.equal na1 na2 &&
+  Option.equal (eq_notation_constr vars) o1 o2 &&
+  (eq_notation_constr vars) u1 u2 &&
+  (eq_notation_constr vars) r1 r2
+| NRec (_, ids1, ts1, us1, rs1), NRec (_, ids2, ts2, us2, rs2) -> (** FIXME? *)
+  let eq (na1, o1, t1) (na2, o2, t2) =
+    Name.equal na1 na2 &&
+    Option.equal (eq_notation_constr vars) o1 o2 &&
+    (eq_notation_constr vars) t1 t2
+  in
+  Array.equal Id.equal ids1 ids2 &&
+  Array.equal (List.equal eq) ts1 ts2 &&
+  Array.equal (eq_notation_constr vars) us1 us2 &&
+  Array.equal (eq_notation_constr vars) rs1 rs2
+| NSort s1, NSort s2 ->
+  Miscops.glob_sort_eq s1 s2
+| NCast (t1, c1), NCast (t2, c2) ->
+  (eq_notation_constr vars) t1 t2 && cast_type_eq (eq_notation_constr vars) c1 c2
+| (NRef _ | NVar _ | NApp _ | NHole _ | NList _ | NLambda _ | NProd _
+  | NBinderList _ | NLetIn _ | NCases _ | NLetTuple _ | NIf _
+  | NRec _ | NSort _ | NCast _), _ -> false
+
+(**********************************************************************)
+(* 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."
+  | Anonymous -> CErrors.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
@@ -36,6 +124,14 @@ let rec cases_pattern_fold_map loc g e = function
       let e',patl' = List.fold_map (cases_pattern_fold_map loc g) e patl in
       e', PatCstr (loc,cstr,patl',na')
 
+let subst_binder_type_vars l = function
+  | Evar_kinds.BinderType (Name id) ->
+     let id =
+       try match Id.List.assoc id l with GVar(_,id') -> id' | _ -> id
+       with Not_found -> id in
+     Evar_kinds.BinderType (Name id)
+  | e -> e
+
 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) ->
@@ -48,6 +144,7 @@ let rec subst_glob_vars l = function
 	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)
+  | GHole (loc,x,naming,arg) -> GHole (loc,subst_binder_type_vars l x,naming,arg)
   | r -> map_glob_constr (subst_glob_vars l) r (* assume: id is not binding *)
 
 let ldots_var = Id.of_string ".."
@@ -105,7 +202,6 @@ let glob_constr_of_notation_constr_with_binders loc g f e = function
   | 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 =
@@ -113,7 +209,7 @@ let glob_constr_of_notation_constr loc 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)
@@ -143,96 +239,6 @@ let split_at_recursive_part c =
   | 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 rec eq_notation_constr t1 t2 = match t1, t2 with
-| NRef gr1, NRef gr2 -> eq_gr gr1 gr2
-| NVar id1, NVar id2 -> Id.equal id1 id2
-| NApp (t1, a1), NApp (t2, a2) ->
-  eq_notation_constr t1 t2 && List.equal eq_notation_constr a1 a2
-| NHole (_, _, _), NHole (_, _, _) -> true (** FIXME? *)
-| NList (i1, j1, t1, u1, b1), NList (i2, j2, t2, u2, b2) ->
-  Id.equal i1 i2 && Id.equal j1 j2 && eq_notation_constr t1 t2 &&
-  eq_notation_constr u1 u2 && b1 == b2
-| NLambda (na1, t1, u1), NLambda (na2, t2, u2) ->
-  Name.equal na1 na2 && eq_notation_constr t1 t2 && eq_notation_constr u1 u2
-| NProd (na1, t1, u1), NProd (na2, t2, u2) ->
-  Name.equal na1 na2 && eq_notation_constr t1 t2 && eq_notation_constr u1 u2
-| NBinderList (i1, j1, t1, u1), NBinderList (i2, j2, t2, u2) ->
-  Id.equal i1 i2 && Id.equal j1 j2 && eq_notation_constr t1 t2 &&
-  eq_notation_constr u1 u2
-| NLetIn (na1, t1, u1), NLetIn (na2, t2, u2) ->
-  Name.equal na1 na2 && eq_notation_constr t1 t2 && eq_notation_constr u1 u2
-| NCases (_, o1, r1, p1), NCases (_, o2, r2, p2) -> (** FIXME? *)
-  let eqpat (p1, t1) (p2, t2) =
-    List.equal cases_pattern_eq p1 p2 &&
-    eq_notation_constr t1 t2
-  in
-  let eqf (t1, (na1, o1)) (t2, (na2, o2)) =
-    let eq (i1, n1) (i2, n2) = eq_ind i1 i2 && List.equal Name.equal n1 n2 in
-    eq_notation_constr t1 t2 && Name.equal na1 na2 && Option.equal eq o1 o2
-  in
-  Option.equal eq_notation_constr o1 o2 &&
-  List.equal eqf r1 r2 &&
-  List.equal eqpat p1 p2
-| NLetTuple (nas1, (na1, o1), t1, u1), NLetTuple (nas2, (na2, o2), t2, u2) ->
-  List.equal Name.equal nas1 nas2 &&
-  Name.equal na1 na2 &&
-  Option.equal eq_notation_constr o1 o2 &&
-  eq_notation_constr t1 t2 &&
-  eq_notation_constr u1 u2
-| NIf (t1, (na1, o1), u1, r1), NIf (t2, (na2, o2), u2, r2) ->
-  eq_notation_constr t1 t2 &&
-  Name.equal na1 na2 &&
-  Option.equal eq_notation_constr o1 o2 &&
-  eq_notation_constr u1 u2 &&
-  eq_notation_constr r1 r2
-| NRec (_, ids1, ts1, us1, rs1), NRec (_, ids2, ts2, us2, rs2) -> (** FIXME? *)
-  let eq (na1, o1, t1) (na2, o2, t2) =
-    Name.equal na1 na2 &&
-    Option.equal eq_notation_constr o1 o2 &&
-    eq_notation_constr t1 t2
-  in
-  Array.equal Id.equal ids1 ids2 &&
-  Array.equal (List.equal eq) ts1 ts2 &&
-  Array.equal eq_notation_constr us1 us2 &&
-  Array.equal eq_notation_constr rs1 rs2
-| NSort s1, NSort s2 ->
-  Miscops.glob_sort_eq s1 s2
-| NPatVar p1, NPatVar p2 ->
-  Id.equal p1 p2
-| NCast (t1, c1), NCast (t2, c2) ->
-  eq_notation_constr t1 t2 && cast_type_eq eq_notation_constr c1 c2
-| (NRef _ | NVar _ | NApp _ | NHole _ | NList _ | NLambda _ | NProd _
-  | NBinderList _ | NLetIn _ | NCases _ | NLetTuple _ | NIf _
-  | NRec _ | NSort _ | NPatVar _ | NCast _), _ -> false
-
-
 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 ->
@@ -240,7 +246,13 @@ let check_is_hole id = function GHole _ -> () | 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 pair_equal eq1 eq2 (a,b) (a',b') = eq1 a a' && eq2 b b'
+
+type recursive_pattern_kind =
+| RecursiveTerms of bool (* associativity *)
+| RecursiveBinders of glob_constr * glob_constr
+
+let compare_recursive_parts found f f' (iterator,subc) =
   let diff = ref None in
   let terminator = ref None in
   let rec aux c1 c2 = match c1,c2 with
@@ -261,18 +273,16 @@ let compare_recursive_parts found f (iterator,subc) =
       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
+        let () = diff := Some (x, y, RecursiveTerms 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
+        let () = diff := Some (x, y, RecursiveBinders (t_x,t_y)) in
         aux c term
       | Some _ -> false
       end
@@ -286,29 +296,42 @@ let compare_recursive_parts found f (iterator,subc) =
 	(* 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
+    | Some (x,y,RecursiveTerms lassoc) ->
+        let newfound,x,y,lassoc =
+          if List.mem_f (pair_equal Id.equal Id.equal) (x,y) (pi2 !found) ||
+             List.mem_f (pair_equal Id.equal Id.equal) (x,y) (pi3 !found)
+          then
+            !found,x,y,lassoc
+          else if List.mem_f (pair_equal Id.equal Id.equal) (y,x) (pi2 !found) ||
+                  List.mem_f (pair_equal Id.equal Id.equal) (y,x) (pi3 !found)
+          then
+            !found,y,x,not lassoc
+          else
+            (pi1 !found, (x,y) :: pi2 !found, pi3 !found),x,y,lassoc in
 	let iterator =
-	  f (if lassoc then subst_glob_vars [y,GVar(Loc.ghost,x)] iterator
-	  else iterator) in
+	  f' (if lassoc then iterator
+	      else subst_glob_vars [x,GVar(Loc.ghost,y)] iterator) in
 	(* found have been collected by compare_constr *)
 	found := newfound;
 	NList (x,y,iterator,f (Option.get !terminator),lassoc)
-    | Some (x,y,None) ->
+    | Some (x,y,RecursiveBinders (t_x,t_y)) ->
 	let newfound = (pi1 !found, pi2 !found, (x,y) :: pi3 !found) in
-	let iterator = f iterator in
+	let iterator = f' (subst_glob_vars [x,GVar(Loc.ghost,y)] iterator) in
 	(* found have been collected by compare_constr *)
 	found := newfound;
+	check_is_hole x t_x;
+	check_is_hole y t_y;
 	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 has_ltac = ref false 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)
+    try compare_recursive_parts found aux aux' (split_at_recursive_part c)
     with Not_found ->
     found := keepfound;
     match c with
@@ -350,20 +373,20 @@ let notation_constr_and_vars_of_glob_constr a =
       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)
+  | GHole (_,w,naming,arg) ->
+     if arg != None then has_ltac := true;
+     NHole (w, naming, arg)
   | GRef (_,r,_) -> NRef r
-  | GPatVar (_,(_,n)) -> NPatVar n
-  | GEvar _ ->
+  | GEvar _ | GPatVar _ ->
       error "Existential variables not allowed in notations."
 
   in
   let t = aux a in
   (* Side effect *)
-  t, !found
+  t, !found, !has_ltac
 
-let pair_equal eq1 eq2 (a,b) (a',b') = eq1 a a' && eq2 b b'
-
-let check_variables nenv (found,foundrec,foundrecbinding) =
+let check_variables_and_reversibility nenv (found,foundrec,foundrecbinding) =
+  let injective = ref true in
   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
@@ -386,7 +409,7 @@ let check_variables nenv (found,foundrec,foundrecbinding) =
 	error
           (Id.to_string x ^
           " should not be bound in a recursive pattern of the right-hand side.")
-      else nenv.ninterp_only_parse <- true
+      else injective := false
   in
   let check_pair s x y where =
     if not (List.mem_f (pair_equal Id.equal Id.equal) (x,y) where) then
@@ -406,13 +429,15 @@ let check_variables nenv (found,foundrec,foundrecbinding) =
 	  with Not_found -> check_bound x
 	end
     | NtnInternTypeIdent -> check_bound x in
-  Id.Map.iter check_type vars
+  Id.Map.iter check_type vars;
+  !injective
 
 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
+  let a, found, has_ltac = notation_constr_and_vars_of_glob_constr a in
+  let injective = check_variables_and_reversibility nenv found in
+  a, not has_ltac && injective
 
+(**********************************************************************)
 (* Substitution of kernel names, avoiding a list of bound identifiers *)
 
 let notation_constr_of_constr avoiding t =
@@ -420,7 +445,6 @@ let notation_constr_of_constr avoiding t =
   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
 
@@ -438,7 +462,7 @@ let rec subst_notation_constr subst bound raw =
   | NRef ref ->
       let ref',t = subst_global subst ref in
 	if ref' == ref then raw else
-	  notation_constr_of_constr bound t
+	  fst (notation_constr_of_constr bound t)
 
   | NVar _ -> raw
 
@@ -526,7 +550,7 @@ let rec subst_notation_constr subst bound raw =
       if dll' == dll && tl' == tl && bl' == bl then raw else
 	  NRec (fk,idl,dll',tl',bl')
 
-  | NPatVar _ | NSort _ -> raw
+  | NSort _ -> raw
 
   | NHole (knd, naming, solve) ->
     let nknd = match knd with
@@ -548,7 +572,8 @@ 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 *)
+(**********************************************************************)
+(* Pattern-matching a [glob_constr] against a [notation_constr]       *)
 
 let abstract_return_type_context pi mklam tml rtno =
   Option.map (fun rtn ->
@@ -567,6 +592,18 @@ 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))
 
+let is_term_meta id metas =
+  try match Id.List.assoc id metas with _,(NtnTypeConstr | NtnTypeConstrList) -> true | _ -> false
+  with Not_found -> false
+
+let is_onlybinding_meta id metas =
+  try match Id.List.assoc id metas with _,NtnTypeOnlyBinder -> true | _ -> false
+  with Not_found -> false
+
+let is_bindinglist_meta id metas =
+  try match Id.List.assoc id metas with _,NtnTypeBinderList -> true | _ -> false
+  with Not_found -> false
+
 exception No_match
 
 let rec alpha_var id1 id2 = function
@@ -575,26 +612,231 @@ let rec alpha_var id1 id2 = function
   | _::idl -> alpha_var id1 id2 idl
   | [] -> Id.equal id1 id2
 
-let add_env alp (sigma,sigmalist,sigmabinders) var v =
+let alpha_rename alpmetas v =
+  if alpmetas == [] then v
+  else try rename_glob_vars alpmetas v with UnsoundRenaming -> raise No_match
+
+let add_env (alp,alpmetas) (terms,onlybinders,termlists,binderlists) 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;
+  (* [alp] is used when matching a pattern "fun x => ... x ... ?var ... x ..."
+     with an actual term "fun z => ... z ..." when "x" is not bound in the
+     notation, as in "Notation "'twice_upto' y" := (fun x => x + x + y)". Then
+     we keep (z,x) in alp, and we have to check that what the [v] which is bound
+     to [var] does not contain z *)
+  if not (Id.equal ldots_var var) &&
+     List.exists (fun (id,_) -> occur_glob_constr id v) alp then raise No_match;
+  (* [alpmetas] is used when matching a pattern "fun x => ... x ... ?var ... x ..."
+     with an actual term "fun z => ... z ..." when "x" is bound in the
+     notation and the name "x" cannot be changed to "z", e.g. because
+     used at another occurrence, as in "Notation "'lam' y , P & Q" :=
+     ((fun y => P),(fun y => Q))". Then, we keep (z,y) in alpmetas, and we
+     have to check that "fun z => ... z ..." denotes the same term as
+     "fun x => ... x ... ?var ... x" up to alpha-conversion when [var]
+     is instantiated by [v];
+     Currently, we fail, but, eventually, [x] in [v] could be replaced by [x],
+     and, in match_, when finding "x" in subterm, failing because of a capture,
+     and, in match_, when finding "z" in subterm, replacing it with "x",
+     and, in an even further step, being even more robust, independent of the order, so
+     that e.g. the notation for ex2 works on "x y |- ex2 (fun x => y=x) (fun y => x=y)"
+     by giving, say, "exists2 x0, y=x0 & x=x0", but this would typically require the
+     glob_constr_eq in bind_term_env to be postponed in match_notation_constr, and the
+     choice of exact variable be done there; but again, this would be a non-trivial
+     refinement *)
+  let v = alpha_rename alpmetas v in
   (* TODO: handle the case of multiple occs in different scopes *)
-  ((var,v)::sigma,sigmalist,sigmabinders)
+  ((var,v)::terms,onlybinders,termlists,binderlists)
+
+let add_termlist_env (alp,alpmetas) (terms,onlybinders,termlists,binderlists) var vl =
+  if List.exists (fun (id,_) -> List.exists (occur_glob_constr id) vl) alp then raise No_match;
+  let vl = List.map (alpha_rename alpmetas) vl in
+  (terms,onlybinders,(var,vl)::termlists,binderlists)
+
+let add_binding_env alp (terms,onlybinders,termlists,binderlists) var v =
+  (* TODO: handle the case of multiple occs in different scopes *)
+  (terms,(var,v)::onlybinders,termlists,binderlists)
+
+let add_bindinglist_env (terms,onlybinders,termlists,binderlists) x bl =
+  (terms,onlybinders,termlists,(x,bl)::binderlists)
+
+let rec pat_binder_of_term = function
+  | GVar (loc, id) -> PatVar (loc, Name id)
+  | GApp (loc, GRef (_,ConstructRef cstr,_), l) ->
+     let nparams = Inductiveops.inductive_nparams (fst cstr) in
+     let _,l = List.chop nparams l in
+     PatCstr (loc, cstr, List.map pat_binder_of_term l, Anonymous)
+  | _ -> raise No_match
 
-let bind_env alp (sigma,sigmalist,sigmabinders as fullsigma) var v =
+let bind_term_env alp (terms,onlybinders,termlists,binderlists as sigma) var v =
   try
-    let v' = Id.List.assoc var sigma in
+    let v' = Id.List.assoc var terms in
     match v, v' with
-    | GHole _, _ -> fullsigma
+    | GHole _, _ -> sigma
     | _, GHole _ ->
-      add_env alp (Id.List.remove_assoc var sigma,sigmalist,sigmabinders) var v
+        let sigma = Id.List.remove_assoc var terms,onlybinders,termlists,binderlists in
+        add_env alp sigma var v
     | _, _ ->
-        if glob_constr_eq v v' then fullsigma
+        if glob_constr_eq (alpha_rename (snd alp) v) v' then sigma
         else raise No_match
-  with Not_found -> add_env alp fullsigma var v
+  with Not_found -> add_env alp sigma var v
 
-let bind_binder (sigma,sigmalist,sigmabinders) x bl =
-  (sigma,sigmalist,(x,List.rev bl)::sigmabinders)
+let bind_termlist_env alp (terms,onlybinders,termlists,binderlists as sigma) var vl =
+  try
+    let vl' = Id.List.assoc var termlists in
+    let unify_term v v' =
+      match v, v' with
+      | GHole _, _ -> v'
+      | _, GHole _ -> v
+      | _, _ -> if glob_constr_eq (alpha_rename (snd alp) v) v' then v' else raise No_match in
+    let rec unify vl vl' =
+      match vl, vl' with
+      | [], [] -> []
+      | v :: vl, v' :: vl' -> unify_term v v' :: unify vl vl'
+      | _ -> raise No_match in
+    let vl = unify vl vl' in
+    let sigma = (terms,onlybinders,Id.List.remove_assoc var termlists,binderlists) in
+    add_termlist_env alp sigma var vl
+  with Not_found -> add_termlist_env alp sigma var vl
+
+let bind_term_as_binding_env alp (terms,onlybinders,termlists,binderlists as sigma) var id =
+  try
+    match Id.List.assoc var terms with
+    | GVar (_,id') ->
+       (if not (Id.equal id id') then (fst alp,(id,id')::snd alp) else alp),
+       sigma
+    | _ -> anomaly (str "A term which can be a binder has to be a variable")
+  with Not_found ->
+    (* The matching against a term allowing to find the instance has not been found yet *)
+    (* If it will be a different name, we shall unfortunately fail *)
+    (* TODO: look at the consequences for alp *)
+    alp, add_env alp sigma var (GVar (Loc.ghost,id))
+
+let bind_binding_as_term_env alp (terms,onlybinders,termlists,binderlists as sigma) var id =
+  try
+    let v' = Id.List.assoc var onlybinders in
+    match v' with
+    | Anonymous ->
+        (* Should not occur, since the term has to be bound upwards *)
+        let sigma = (terms,Id.List.remove_assoc var onlybinders,termlists,binderlists) in
+        add_binding_env alp sigma var (Name id)
+    | Name id' ->
+        if Id.equal (rename_var (snd alp) id) id' then sigma else raise No_match
+  with Not_found -> add_binding_env alp sigma var (Name id)
+
+let bind_binding_env alp (terms,onlybinders,termlists,binderlists as sigma) var v =
+  try
+    let v' = Id.List.assoc var onlybinders in
+    match v, v' with
+    | Anonymous, _ -> alp, sigma
+    | _, Anonymous ->
+        let sigma = (terms,Id.List.remove_assoc var onlybinders,termlists,binderlists) in
+        alp, add_binding_env alp sigma var v
+    | Name id1, Name id2 ->
+        if Id.equal id1 id2 then alp,sigma
+        else (fst alp,(id1,id2)::snd alp),sigma
+  with Not_found -> alp, add_binding_env alp sigma var v
+
+let rec map_cases_pattern_name_left f = function
+  | PatVar (loc,na) -> PatVar (loc,f na)
+  | PatCstr (loc,c,l,na) -> PatCstr (loc,c,List.map_left (map_cases_pattern_name_left f) l,f na)
+
+let rec fold_cases_pattern_eq f x p p' = match p, p' with
+  | PatVar (loc,na), PatVar (_,na') -> let x,na = f x na na' in x, PatVar (loc,na)
+  | PatCstr (loc,c,l,na), PatCstr (_,c',l',na') when eq_constructor c c' ->
+     let x,l = fold_cases_pattern_list_eq f x l l' in
+     let x,na = f x na na' in
+     x, PatCstr (loc,c,l,na)
+  | _ -> failwith "Not equal"
+
+and fold_cases_pattern_list_eq f x pl pl' = match pl, pl' with
+  | [], [] -> x, []
+  | p::pl, p'::pl' ->
+     let x, p = fold_cases_pattern_eq f x p p' in
+     let x, pl = fold_cases_pattern_list_eq f x pl pl' in
+     x, p :: pl
+  | _ -> assert 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 bind_bindinglist_env alp (terms,onlybinders,termlists,binderlists as sigma) var bl =
+  let bl = List.rev bl in
+  try
+    let bl' = Id.List.assoc var binderlists in
+    let unify_name alp na na' =
+      match na, na' with
+      | Anonymous, na' -> alp, na'
+      | na, Anonymous -> alp, na
+      | Name id, Name id' ->
+         if Id.equal id id' then alp, na'
+         else (fst alp,(id,id')::snd alp), na' in
+    let unify_pat alp p p' =
+      try fold_cases_pattern_eq unify_name alp p p' with Failure _ -> raise No_match in
+    let unify_term alp v v' =
+      match v, v' with
+      | GHole _, _ -> v'
+      | _, GHole _ -> v
+      | _, _ -> if glob_constr_eq (alpha_rename (snd alp) v) v' then v else raise No_match in
+    let unify_binding_kind bk bk' = if bk == bk' then bk' else raise No_match in
+    let unify_binder alp b b' =
+      match b, b' with
+      | (Inl na, bk, None, t), (Inl na', bk', None, t') (* assum *) ->
+         let alp, na = unify_name alp na na' in
+         alp, (Inl na, unify_binding_kind bk bk', None, unify_term alp t t')
+      | (Inl na, bk, Some c, t), (Inl na', bk', Some c', t') (* let *) ->
+         let alp, na = unify_name alp na na' in
+         alp, (Inl na, unify_binding_kind bk bk', Some (unify_term alp c c'), unify_term alp t t')
+      | (Inr p, bk, None, t), (Inr p', bk', None, t') (* pattern *) ->
+         let alp, p = unify_pat alp p p' in
+         alp, (Inr p, unify_binding_kind bk bk', None, unify_term alp t t')
+      | _ -> raise No_match in
+    let rec unify alp bl bl' =
+    match bl, bl' with
+    | [], [] -> alp, []
+    | b :: bl, b' :: bl' ->
+       let alp,b = unify_binder alp b b' in
+       let alp,bl = unify alp bl bl' in
+       alp, b :: bl
+    | _ -> raise No_match in
+    let alp, bl = unify alp bl bl' in
+    let sigma = (terms,Id.List.remove_assoc var onlybinders,termlists,binderlists) in
+    alp, add_bindinglist_env sigma var bl
+  with Not_found ->
+    alp, add_bindinglist_env sigma var bl
+
+let bind_bindinglist_as_term_env alp (terms,onlybinders,termlists,binderlists) var cl =
+  try
+    let bl' = Id.List.assoc var binderlists in
+    let unify_id id na' =
+      match na' with
+      | Anonymous -> Name (rename_var (snd alp) id)
+      | Name id' ->
+         if Id.equal (rename_var (snd alp) id) id' then na' else raise No_match in
+    let unify_pat p p' =
+      if cases_pattern_eq (map_cases_pattern_name_left (name_app (rename_var (snd alp))) p) p' then p'
+      else raise No_match in
+    let unify_term_binder c b' =
+      match c, b' with
+      | GVar (_, id), (Inl na', bk', None, t') (* assum *) ->
+         (Inl (unify_id id na'), bk', None, t')
+      | c, (Inr p', bk', None, t') (* pattern *) ->
+         let p = pat_binder_of_term c in
+         (Inr (unify_pat p p'), bk', None, t')
+      | _ -> raise No_match in
+    let rec unify cl bl' =
+    match cl, bl' with
+    | [], [] -> []
+    | c :: cl, (Inl _, _, Some _,t) :: bl' -> unify cl bl'
+    | c :: cl, b' :: bl' -> unify_term_binder c b' :: unify cl bl'
+    | _ -> raise No_match in
+    let bl = unify cl bl' in
+    let sigma = (terms,onlybinders,termlists,Id.List.remove_assoc var binderlists) in
+    add_bindinglist_env sigma var bl
+  with Not_found ->
+    anomaly (str "There should be a binder list bindings this list of terms")
 
 let match_fix_kind fk1 fk2 =
   match (fk1,fk2) with
@@ -615,12 +857,16 @@ let match_opt f sigma t1 t2 = match (t1,t2) with
   | _ -> 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
+  | (na1,Name id2) when is_onlybinding_meta id2 metas ->
+      bind_binding_env alp sigma id2 na1
+  | (Name id1,Name id2) when is_term_meta id2 metas ->
+      (* We let the non-binding occurrence define the rhs and hence reason up to *)
+      (* alpha-conversion for the given occurrence of the name (see #4592)) *)
+      bind_term_as_binding_env alp sigma id2 id1
+  | (Anonymous,Name id2) when is_term_meta id2 metas ->
+      (* We let the non-binding occurrence define the rhs *)
+      alp, sigma
+  | (Name id1,Name id2) -> ((id1,id2)::fst alp, snd alp),sigma
   | (Anonymous,Anonymous) -> alp,sigma
   | _ -> raise No_match
 
@@ -636,45 +882,69 @@ let rec match_cases_pattern_binders metas acc pat1 pat2 =
 let glue_letin_with_decls = true
 
 let rec match_iterated_binders islambda decls = function
+  | GLambda (_,Name p,bk,t,GCases (_,LetPatternStyle,None,[(GVar(_,e),_)],[(_,_,[cp],b)]))
+      when islambda && Id.equal p e ->
+      match_iterated_binders islambda ((Inr cp,bk,None,t)::decls) b
   | GLambda (_,na,bk,t,b) when islambda ->
-      match_iterated_binders islambda ((na,bk,None,t)::decls) b
+      match_iterated_binders islambda ((Inl na,bk,None,t)::decls) b
+  | GProd (_,Name p,bk,t,GCases (_,LetPatternStyle,None,[(GVar(_,e),_)],[(_,_,[cp],b)]))
+      when not islambda && Id.equal p e ->
+      match_iterated_binders islambda ((Inr cp,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
+      match_iterated_binders islambda ((Inl 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
+	((Inl 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 remove_sigma x (terms,onlybinders,termlists,binderlists) =
+  (Id.List.remove_assoc x terms,onlybinders,termlists,binderlists)
 
-let match_abinderlist_with_app match_fun metas sigma rest x iter termin =
-  let rec aux sigma acc rest =
+let remove_bindinglist_sigma x (terms,onlybinders,termlists,binderlists) =
+  (terms,onlybinders,termlists,Id.List.remove_assoc x binderlists)
+
+let add_ldots_var metas = (ldots_var,((None,[]),NtnTypeConstr))::metas
+
+let add_meta_bindinglist x metas = (x,((None,[]),NtnTypeBinderList))::metas
+
+let match_binderlist_with_app match_fun alp metas sigma rest x y iter termin =
+  let rec aux sigma bl 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 metas = add_ldots_var (add_meta_bindinglist y metas) in
+      let (terms,_,_,binderlists as sigma) = match_fun alp metas sigma rest iter in
+      let rest = Id.List.assoc ldots_var terms in
       let b =
-        match Id.List.assoc x (pi3 sigma) with [b] -> b | _ ->assert false
+        match Id.List.assoc y binderlists 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 sigma = remove_bindinglist_sigma y (remove_sigma ldots_var sigma) in
+      aux sigma (b::bl) rest
+    with No_match when not (List.is_empty bl) ->
+      bl, rest, sigma in
+  let bl,rest,sigma = aux sigma [] rest in
+  let alp,sigma = bind_bindinglist_env alp sigma x bl in
+  match_fun alp metas sigma rest termin
+
+let add_meta_term x metas = (x,((None,[]),NtnTypeConstr))::metas
 
-let match_alist match_fun metas sigma rest x iter termin lassoc =
+let match_termlist match_fun alp metas sigma rest x y 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
+      let metas = add_ldots_var (add_meta_term y metas) in
+      let (terms,_,_,_ as sigma) = match_fun metas sigma rest iter in
+      let rest = Id.List.assoc ldots_var terms in
+      let t = Id.List.assoc y terms in
+      let sigma = remove_sigma y (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 l,(terms,onlybinders,termlists,binderlists as sigma) = aux sigma [] rest in
+  let l = if lassoc then l else List.rev l in
+  if is_bindinglist_meta x metas then
+    (* This is a recursive pattern for both bindings and terms; it is *)
+    (* registered for binders *)
+    bind_bindinglist_as_term_env alp sigma x l
+  else
+    bind_termlist_env alp sigma x l
 
 let does_not_come_from_already_eta_expanded_var =
   (* This is hack to avoid looping on a rule with rhs of the form *)
@@ -688,41 +958,67 @@ let does_not_come_from_already_eta_expanded_var =
   (* checked). *)
   function GVar _ -> false | _ -> true
 
-let rec match_ inner u alp (tmetas,blmetas as metas) sigma a1 a2 =
+let rec match_ inner u alp 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
+  | r1, NVar id2 when is_term_meta id2 metas -> bind_term_env alp sigma id2 r1
+  | GVar (_,id1), NVar id2 when is_onlybinding_meta id2 metas -> bind_binding_as_term_env alp sigma id2 id1
+  | r1, NVar id2 when is_bindinglist_meta id2 metas -> bind_term_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
+  | r1, NList (x,y,iter,termin,lassoc) ->
+      match_termlist (match_hd u alp) alp metas sigma r1 x y iter termin lassoc
+
+  (* "λ p, let 'cp = p in t" -> "λ 'cp, t" *)
+  | GLambda (_,Name p,bk,t1,GCases (_,LetPatternStyle,None,[(GVar(_,e),_)],[(_,_,[cp],b1)])),
+    NBinderList (x,_,NLambda (Name _id2,_,b2),termin) when Id.equal p e ->
+      let (decls,b) = match_iterated_binders true [(Inr cp,bk,None,t1)] b1 in
+      let alp,sigma = bind_bindinglist_env alp sigma x decls in
+      match_in u alp metas sigma b termin
 
   (* 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
+  | GLambda (_,na1,bk,t1,b1), NBinderList (x,_,NLambda (Name _id2,_,b2),termin)->
+      let (decls,b) = match_iterated_binders true [(Inl 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)
+      let alp,sigma = bind_bindinglist_env alp sigma x decls in
+      match_in u alp metas sigma b termin
+
+  (* "∀ p, let 'cp = p in t" -> "∀ 'cp, t" *)
+  | GProd (_,Name p,bk,t1,GCases (_,LetPatternStyle,None,[(GVar(_,e),_)],[(_,_,[cp],b1)])),
+    NBinderList (x,_,NProd (Name _id2,_,b2),(NVar v as termin)) when Id.equal p e ->
+      let (decls,b) = match_iterated_binders true [(Inr cp,bk,None,t1)] b1 in
+      let alp,sigma = bind_bindinglist_env alp sigma x decls in
+      match_in u alp metas sigma 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
+      let (decls,b) = match_iterated_binders false [(Inl 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
+      let alp,sigma = bind_bindinglist_env alp sigma x decls in
+      match_in u alp metas sigma 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
+  | r, NBinderList (x,y,iter,termin) ->
+      match_binderlist_with_app (match_hd u) alp metas sigma r x y 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
+  | GLambda (_,Name p,bk,t,GCases (_,LetPatternStyle,None,[(GVar(_,e),_)],[(_,_,[cp],b1)])),
+    NLambda (Name id,_,b2)
+      when is_bindinglist_meta id metas ->
+      let alp,sigma = bind_bindinglist_env alp sigma id [(Inr cp,bk,None,t)] in
+      match_in u alp metas sigma b1 b2
+  | GLambda (_,na,bk,t,b1), NLambda (Name id,_,b2)
+      when is_bindinglist_meta id metas ->
+      let alp,sigma = bind_bindinglist_env alp sigma id [(Inl na,bk,None,t)] in
+      match_in u alp metas sigma 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
+      when is_bindinglist_meta id metas && na != Anonymous ->
+      let alp,sigma = bind_bindinglist_env alp sigma id [(Inl na,bk,None,t)] in
+      match_in u alp metas sigma b1 b2
 
   (* Matching compositionally *)
-  | GVar (_,id1), NVar id2 when alpha_var id1 id2 alp -> sigma
+  | GVar (_,id1), NVar id2 when alpha_var id1 id2 (fst 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 =
@@ -794,15 +1090,21 @@ let rec match_ inner u alp (tmetas,blmetas as metas) sigma a1 a2 =
      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
+  | b1, NLambda (Name id as na,(NHole _ | NVar _ as t2),b2) when inner ->
+      let avoid =
+        free_glob_vars b1 @ (* as in Namegen: *) glob_visible_short_qualid b1 in
+      let id' = Namegen.next_ident_away id avoid 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
+      | NVar id2 -> bind_term_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
+      let (alp,sigma) =
+        if is_bindinglist_meta id metas then
+          bind_bindinglist_env alp sigma id [(Inl (Name id'),Explicit,None,t1)]
+        else
+          match_names metas (alp,sigma) (Name id') na in
+      match_in u alp metas sigma (mkGApp Loc.ghost b1 (GVar (Loc.ghost,id'))) b2
 
   | (GRec _ | GEvar _), _
   | _,_ -> raise No_match
@@ -823,14 +1125,20 @@ and match_equations u alp metas sigma (_,_,patl1,rhs1) (patl2,rhs2) =
       (alp,sigma) patl1 patl2 in
   match_in u alp metas sigma rhs1 rhs2
 
+let term_of_binder = function
+  | Name id -> GVar (Loc.ghost,id)
+  | Anonymous -> GHole (Loc.ghost,Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None)
+
+type glob_decl2 =
+    (name, cases_pattern) Util.union * Decl_kinds.binding_kind *
+      glob_constr option * glob_constr
+
 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
+  let terms,binders,termlists,binderlists =
+    match_ false u ([],[]) metas ([],[],[],[]) c pat in
   (* Reorder canonically the substitution *)
-  let find x =
-    try Id.List.assoc x terms
+  let find_binder x =
+    try term_of_binder (Id.List.assoc x binders)
     with Not_found ->
       (* Happens for binders bound to Anonymous *)
       (* Find a better way to propagate Anonymous... *)
@@ -838,11 +1146,15 @@ let match_notation_constr u c (metas,pat) =
   List.fold_right (fun (x,(scl,typ)) (terms',termlists',binders') ->
     match typ with
     | NtnTypeConstr ->
-       ((find x, scl)::terms',termlists',binders')
+      let term = try Id.List.assoc x terms with Not_found -> raise No_match in
+       ((term, scl)::terms',termlists',binders')
+    | NtnTypeOnlyBinder ->
+       ((find_binder 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'))
+      let bl = try Id.List.assoc x binderlists with Not_found -> raise No_match in
+       (terms',termlists',(bl, scl)::binders'))
     metas ([],[],[])
 
 (* Matching cases pattern *)
@@ -851,17 +1163,31 @@ let add_patterns_for_params ind l =
   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 =
+let bind_env_cases_pattern (terms,x,termlists,y as sigma) var v =
   try
-    let vvar = Id.List.assoc var sigma in
-    if cases_pattern_eq v vvar then fullsigma else raise No_match
+    let vvar = Id.List.assoc var terms in
+    if cases_pattern_eq v vvar then sigma else raise No_match
   with Not_found ->
     (* TODO: handle the case of multiple occs in different scopes *)
-    (var,v)::sigma,sigmalist,x
+    (var,v)::terms,x,termlists,y
+
+let match_cases_pattern_list match_fun metas sigma rest x y iter termin lassoc =
+  let rec aux sigma acc rest =
+    try
+      let metas = add_ldots_var (add_meta_term y metas) in
+      let (terms,_,_,_ as sigma) = match_fun metas sigma rest iter in
+      let rest = Id.List.assoc ldots_var terms in
+      let t = Id.List.assoc y terms in
+      let sigma = remove_sigma y (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,(terms,onlybinders,termlists,binderlists as sigma) = aux sigma [] rest in
+  (terms,onlybinders,(x,if lassoc then l else List.rev l)::termlists, binderlists)
 
-let rec match_cases_pattern metas sigma a1 a2 =
+let rec match_cases_pattern metas (terms,(),termlists,() as sigma) a1 a2 =
  match (a1,a2) with
-  | r1, NVar id2 when Id.List.mem id2 metas -> (bind_env_cases_pattern sigma id2 r1),(0,[])
+  | r1, NVar id2 when Id.List.mem_assoc 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)
@@ -875,15 +1201,15 @@ let rec match_cases_pattern metas sigma a1 a2 =
       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,[])
+  | r1, NList (x,y,iter,termin,lassoc) ->
+      (match_cases_pattern_list (match_cases_pattern_no_more_args)
+	metas (terms,(),termlists,()) r1 x y 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
+      | out,(_,[]) -> out
+      | _ -> raise No_match
 
 let match_ind_pattern metas sigma ind pats a2 =
   match a2 with
@@ -904,16 +1230,15 @@ 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')
+      | NtnTypeOnlyBinder -> assert false
       | 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
+  let (terms,(),termlists,()),more_args = match_cases_pattern metas ([],(),[],()) 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
+  let (terms,(),termlists,()),more_args = match_ind_pattern metas ([],(),[],()) ind args pat in
   reorder_canonically_substitution terms termlists metas, more_args
diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli
index 280ccfd2..c8fcbf74 100644
--- a/interp/notation_ops.mli
+++ b/interp/notation_ops.mli
@@ -10,24 +10,28 @@ open Names
 open Notation_term
 open Glob_term
 
-(** Utilities about [notation_constr] *)
+(** {5 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 eq_notation_constr : Id.t list * Id.t list -> notation_constr -> notation_constr -> bool
 
-val notation_constr_of_glob_constr : notation_interp_env ->
-  glob_constr -> notation_constr
+(** Substitution of kernel names in interpretation data                *)
 
+val subst_interpretation :
+  Mod_subst.substitution -> interpretation -> interpretation
+                                                
 (** 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
+(** {5 Translation back and forth between [glob_constr] and [notation_constr]} *)
+
+(** Translate a [glob_constr] into a notation given the list of variables
+    bound by the notation; also interpret recursive patterns           *)
 
-val eq_notation_constr : notation_constr -> notation_constr -> bool
+val notation_constr_of_glob_constr : notation_interp_env ->
+  glob_constr -> notation_constr * reversibility_flag
 
-(** Re-interpret a notation as a [glob_constr], taking care of binders     *)
+(** 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) ->
@@ -36,14 +40,19 @@ val glob_constr_of_notation_constr_with_binders : Loc.t ->
 
 val glob_constr_of_notation_constr : Loc.t -> notation_constr -> glob_constr
 
+(** {5 Matching a notation pattern against a [glob_constr]} *)
+
 (** [match_notation_constr] matches a [glob_constr] against a notation
     interpretation; raise [No_match] if the matching fails   *)
 
 exception No_match
 
+type glob_decl2 =
+    (name, cases_pattern) Util.union * Decl_kinds.binding_kind *
+      glob_constr option * glob_constr
 val match_notation_constr : bool -> glob_constr -> interpretation ->
       (glob_constr * subscopes) list * (glob_constr list * subscopes) list *
-      (glob_decl list * subscopes) list
+      (glob_decl2 list * subscopes) list
 
 val match_notation_constr_cases_pattern :
   cases_pattern -> interpretation ->
@@ -55,9 +64,5 @@ val match_notation_constr_ind_pattern :
   ((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
+(** {5 Matching a notation pattern against a [glob_constr]} *)
 
-val add_patterns_for_params : inductive -> cases_pattern list -> cases_pattern list
diff --git a/interp/reserve.ml b/interp/reserve.ml
index 7e42c1a2..388ca080 100644
--- a/interp/reserve.ml
+++ b/interp/reserve.ml
@@ -8,7 +8,7 @@
 
 (* Reserved names *)
 
-open Errors
+open CErrors
 open Util
 open Pp
 open Names
diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml
index 1f28ba65..47877421 100644
--- a/interp/smartlocate.ml
+++ b/interp/smartlocate.ml
@@ -13,7 +13,7 @@
 
 (* *)
 open Pp
-open Errors
+open CErrors
 open Libnames
 open Globnames
 open Misctypes
diff --git a/interp/stdarg.ml b/interp/stdarg.ml
index 9c3ed941..2a7d52e3 100644
--- a/interp/stdarg.ml
+++ b/interp/stdarg.ml
@@ -7,24 +7,29 @@
 (************************************************************************)
 
 open Genarg
+open Geninterp
+
+let make0 ?dyn name =
+  let wit = Genarg.make0 name in
+  let () = register_val0 wit dyn in
+  wit
 
 let wit_unit : unit uniform_genarg_type =
-  make0 None "unit"
+  make0 "unit"
 
 let wit_bool : bool uniform_genarg_type =
-  make0 None "bool"
+  make0 "bool"
 
 let wit_int : int uniform_genarg_type =
-  make0 None "int"
+  make0 "int"
 
 let wit_string : string uniform_genarg_type =
-  make0 None "string"
+  make0 "string"
 
 let wit_pre_ident : string uniform_genarg_type =
-  make0 None "preident"
+  make0 ~dyn:(val_tag (topwit wit_string)) "preident"
+
+(** Aliases for compatibility *)
 
-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"
+let wit_integer = wit_int
+let wit_preident = wit_pre_ident
diff --git a/interp/stdarg.mli b/interp/stdarg.mli
index d8904dab..e1f648d7 100644
--- a/interp/stdarg.mli
+++ b/interp/stdarg.mli
@@ -19,3 +19,8 @@ val wit_int : int uniform_genarg_type
 val wit_string : string uniform_genarg_type
 
 val wit_pre_ident : string uniform_genarg_type
+
+(** Aliases for compatibility *)
+
+val wit_integer : int uniform_genarg_type
+val wit_preident : string uniform_genarg_type
diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml
index db548ec3..2523063e 100644
--- a/interp/syntax_def.ml
+++ b/interp/syntax_def.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Pp
 open Names
@@ -43,7 +43,7 @@ let is_alias_of_already_visible_name sp = function
       false
 
 let open_syntax_constant i ((sp,kn),(_,pat,onlyparse)) =
-  if not (is_alias_of_already_visible_name sp pat) then begin
+  if not (Int.equal i 1 && is_alias_of_already_visible_name sp pat) then begin
     Nametab.push_syndef (Nametab.Exactly i) sp kn;
     match onlyparse with
     | None ->
@@ -84,23 +84,21 @@ let declare_syntactic_definition local id onlyparse pat =
 
 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
+let pr_compat_warning (kn, def, v) =
+  let pp_def = match def with
+    | [], NRef r -> spc () ++ str "is" ++ spc () ++ pr_global_env Id.Set.empty r
+    | _ -> strbrk " is a compatibility notation"
+  in
+  let since = strbrk " since Coq > " ++ str (Flags.pr_version v) ++ str "." in
+  pr_syndef kn ++ pp_def ++ since
 
-let is_verbose_compat () =
-  !verbose_compat_notations || not !allow_compat_notations
+let warn_compatibility_notation =
+  CWarnings.(create ~name:"compatibility-notation"
+                    ~category:"deprecated" ~default:Disabled pr_compat_warning)
 
 let verbose_compat kn def = function
-  | Some v when is_verbose_compat () && Flags.version_strictly_greater v ->
-    let act =
-      if !verbose_compat_notations then msg_warning else errorlabstrm ""
-    in
-    let pp_def = match def with
-      | [], NRef r -> str " is " ++ pr_global_env Id.Set.empty r
-      | _ -> str " is a compatibility notation"
-    in
-    let since = str " since Coq > " ++ str (Flags.pr_version v) ++ str "." in
-    act (pr_syndef kn ++ pp_def ++ since)
+  | Some v when Flags.version_strictly_greater v ->
+     warn_compatibility_notation (kn, def, v)
   | _ -> ()
 
 let search_syntactic_definition kn =
@@ -110,21 +108,3 @@ let search_syntactic_definition kn =
   def
 
 open Goptions
-
-let set_verbose_compat_notations =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "verbose compatibility notations";
-      optkey   = ["Verbose";"Compat";"Notations"];
-      optread  = (fun () -> !verbose_compat_notations);
-      optwrite = ((:=) verbose_compat_notations) }
-
-let set_compat_notations =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "accept compatibility notations";
-      optkey   = ["Compat"; "Notations"];
-      optread  = (fun () -> !allow_compat_notations);
-      optwrite = ((:=) allow_compat_notations) }
diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli
index 7a1c9c5c..55e2848e 100644
--- a/interp/syntax_def.mli
+++ b/interp/syntax_def.mli
@@ -17,9 +17,3 @@ val declare_syntactic_definition : bool -> Id.t ->
   Flags.compat_version option -> syndef_interpretation -> unit
 
 val search_syntactic_definition : kernel_name -> syndef_interpretation
-
-(** Options concerning verbose display of compatibility notations
-    or their deactivation *)
-
-val set_verbose_compat_notations : bool -> unit
-val set_compat_notations : bool -> unit
diff --git a/interp/topconstr.ml b/interp/topconstr.ml
index cc8e697e..79eeacf3 100644
--- a/interp/topconstr.ml
+++ b/interp/topconstr.ml
@@ -8,7 +8,7 @@
 
 (*i*)
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
@@ -19,14 +19,13 @@ open Constrexpr_ops
 (*i*)
 
 
-let oldfashion_patterns = ref (false)
+let asymmetric_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.optname = "no parameters in constructors";
   Goptions.optkey = ["Asymmetric";"Patterns"];
-  Goptions.optread = (fun () -> !oldfashion_patterns);
-  Goptions.optwrite = (fun a -> oldfashion_patterns:=a);
+  Goptions.optread = (fun () -> !asymmetric_patterns);
+  Goptions.optwrite = (fun a -> asymmetric_patterns:=a);
 }
 
 (**********************************************************************)
@@ -52,13 +51,14 @@ let rec cases_pattern_fold_names f a = function
       List.fold_left (cases_pattern_fold_names f) a patl
   | CPatCstr (_,_,patl1,patl2) ->
     List.fold_left (cases_pattern_fold_names f)
-      (List.fold_left (cases_pattern_fold_names f) a patl1) patl2
+      (Option.fold_left (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
+  | CPatCast _ -> assert false
 
 let ids_of_pattern_list =
   List.fold_left
@@ -67,11 +67,11 @@ let ids_of_pattern_list =
     Id.Set.empty
 
 let ids_of_cases_indtype p =
-  Id.Set.elements (cases_pattern_fold_names Id.Set.add Id.Set.empty p)
+  cases_pattern_fold_names Id.Set.add Id.Set.empty p
 
 let ids_of_cases_tomatch tms =
   List.fold_right
-    (fun (_,(ona,indnal)) l ->
+    (fun (_, ona, indnal) l ->
       Option.fold_right (fun t ids -> cases_pattern_fold_names Id.Set.add ids t)
       indnal
         (Option.fold_right (Loc.down_located (name_fold Id.Set.add)) ona l))
@@ -92,6 +92,8 @@ let rec fold_local_binders g f n acc b = function
       f n (fold_local_binders g f n' acc b l) t
   | LocalRawDef ((_,na),t)::l ->
       f n (fold_local_binders g f (name_fold g na n) acc b l) t
+  | LocalPattern _::l ->
+      assert false
   | [] ->
       f n acc b
 
@@ -111,11 +113,11 @@ let fold_constr_expr_with_binders g f n acc = function
   | CDelimiters (loc,_,a) -> f n acc a
   | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CRef _ ->
       acc
-  | CRecord (loc,_,l) -> List.fold_left (fun acc (id, c) -> f n acc c) acc l
+  | CRecord (loc,l) -> List.fold_left (fun acc (id, c) -> f n acc c) acc l
   | CCases (loc,sty,rtnpo,al,bl) ->
       let ids = ids_of_cases_tomatch al in
       let acc = Option.fold_left (f (Id.Set.fold g ids n)) acc rtnpo in
-      let acc = List.fold_left (f n) acc (List.map fst al) in
+      let acc = List.fold_left (f n) acc (List.map (fun (fst,_,_) -> fst) al) in
       List.fold_right (fun (loc,patl,rhs) acc ->
 	let ids = ids_of_pattern_list patl in
 	f (Id.Set.fold g ids n) acc rhs) bl acc
@@ -132,7 +134,7 @@ let fold_constr_expr_with_binders g f n acc = function
 	fold_local_binders g f n'
 	  (fold_local_binders g f n acc t lb) c lb) l acc
   | CCoFix (loc,_,_) ->
-      msg_warning (strbrk "Capture check in multiple binders not done"); acc
+      Feedback.msg_warning (strbrk "Capture check in multiple binders not done"); acc
 
 let free_vars_of_constr_expr c =
   let rec aux bdvars l = function
@@ -170,6 +172,7 @@ let split_at_annot bl na =
               (List.rev ans, LocalRawAssum (r, k, t) :: rest)
             end
 	| LocalRawDef _ as x :: rest -> aux (x :: acc) rest
+        | LocalPattern _ :: rest -> assert false
 	| [] ->
             user_err_loc(loc,"",
 			 str "No parameter named " ++ Nameops.pr_id id ++ str".")
@@ -191,7 +194,9 @@ let map_local_binders f g e bl =
       LocalRawAssum(nal,k,ty) ->
         (map_binder g e nal, LocalRawAssum(nal,k,f e ty)::bl)
     | LocalRawDef((loc,na),ty) ->
-        (name_fold g na e, LocalRawDef((loc,na),f e ty)::bl) in
+        (name_fold g na e, LocalRawDef((loc,na),f e ty)::bl)
+    | LocalPattern _ ->
+        assert false in
   let (e,rbl) = List.fold_left h (e,[]) bl in
   (e, List.rev rbl)
 
@@ -213,14 +218,14 @@ let map_constr_expr_with_binders g f e = function
   | CDelimiters (loc,s,a) -> CDelimiters (loc,s,f e a)
   | CHole _ | CEvar _ | CPatVar _ | CSort _
   | CPrim _ | CRef _ as x -> x
-  | CRecord (loc,p,l) -> CRecord (loc,p,List.map (fun (id, c) -> (id, f e c)) l)
+  | CRecord (loc,l) -> CRecord (loc,List.map (fun (id, c) -> (id, f e c)) l)
   | CCases (loc,sty,rtnpo,a,bl) ->
       let bl = List.map (fun (loc,patl,rhs) ->
         let ids = ids_of_pattern_list patl in
         (loc,patl,f (Id.Set.fold g ids e) rhs)) bl in
       let ids = ids_of_cases_tomatch a in
       let po = Option.map (f (Id.Set.fold g ids e)) rtnpo in
-      CCases (loc, sty, po, List.map (fun (tm,x) -> (f e tm,x)) a,bl)
+      CCases (loc, sty, po, List.map (fun (tm,x,y) -> f e tm,x,y) a,bl)
   | CLetTuple (loc,nal,(ona,po),b,c) ->
       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
diff --git a/interp/topconstr.mli b/interp/topconstr.mli
index 1e867c19..58edd4dd 100644
--- a/interp/topconstr.mli
+++ b/interp/topconstr.mli
@@ -12,7 +12,7 @@ open Constrexpr
 
 (** Topconstr *)
 
-val oldfashion_patterns : bool ref
+val asymmetric_patterns : bool ref
 
 (** Utilities on constr_expr *)
 
@@ -23,7 +23,7 @@ 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 : cases_pattern_expr -> Id.t list
+val ids_of_cases_indtype : cases_pattern_expr -> Id.Set.t
 
 val split_at_annot : local_binder list -> Id.t located option -> local_binder list * local_binder list
 
diff --git a/intf/constrexpr.mli b/intf/constrexpr.mli
index dcdbd47f..0cbb2957 100644
--- a/intf/constrexpr.mli
+++ b/intf/constrexpr.mli
@@ -32,21 +32,25 @@ 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 prim_token =
+  | Numeral of Bigint.bigint (** representation of integer literals that appear in Coq scripts. *)
+  | 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 *)
+  (** [CPatCstr (_, c, l1, l2)] represents ((@c l1) l2) *)
   | RCPatAtom of Loc.t * Id.t option
   | RCPatOr of Loc.t * raw_cases_pattern_expr list
 
+type instance_expr = Misctypes.glob_level 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 *)
+    * cases_pattern_expr list option * cases_pattern_expr list
+  (** [CPatCstr (_, c, Some 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
@@ -56,14 +60,13 @@ type cases_pattern_expr =
   | CPatPrim of Loc.t * prim_token
   | CPatRecord of Loc.t * (reference * cases_pattern_expr) list
   | CPatDelimiters of Loc.t * string * cases_pattern_expr
+  | CPatCast of Loc.t * cases_pattern_expr * constr_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 =
+and 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
@@ -73,9 +76,15 @@ type 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
+  | CRecord of Loc.t * (reference * constr_expr) list
+
+  (* representation of the "let" and "match" constructs *)
+  | CCases of Loc.t                 (* position of the "match" keyword *)
+	      * case_style          (* determines whether this value represents "let" or "match" construct *)
+	      * constr_expr option  (* return-clause *)
+	      * case_expr list
+	      * branch_expr list    (* branches *)
+
   | 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)
@@ -90,8 +99,9 @@ type 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 case_expr = constr_expr                 (* expression that is being matched *)
+	      * Name.t located option       (* as-clause *)
+	      * cases_pattern_expr option   (* in-clause *)
 
 and branch_expr =
   Loc.t * cases_pattern_expr list located list * constr_expr
@@ -115,13 +125,14 @@ and recursion_order_expr =
 and local_binder =
   | LocalRawDef of Name.t located * constr_expr
   | LocalRawAssum of Name.t located list * binder_kind * constr_expr
+  | LocalPattern of Loc.t * cases_pattern_expr * constr_expr option
 
 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
+type typeclass_constraint = (Name.t located * Id.t located list option) * binding_kind * constr_expr
 
 and typeclass_context = typeclass_constraint list
 
diff --git a/intf/extend.mli b/intf/extend.mli
index 03355238..7ba332f7 100644
--- a/intf/extend.mli
+++ b/intf/extend.mli
@@ -8,6 +8,8 @@
 
 (** Entry keys for constr notations *)
 
+type 'a entry = 'a Compat.GrammarMake(CLexer).entry
+
 type side = Left | Right
 
 type gram_assoc = NonA | RightA | LeftA
@@ -50,3 +52,53 @@ type constr_prod_entry_key =
 
 type simple_constr_prod_entry_key =
     (production_level,unit) constr_entry_key_gen
+
+(** {5 AST for user-provided entries} *)
+
+type 'a user_symbol =
+| Ulist1 of 'a user_symbol
+| Ulist1sep of 'a user_symbol * string
+| Ulist0 of 'a user_symbol
+| Ulist0sep of 'a user_symbol * string
+| Uopt of 'a user_symbol
+| Uentry of 'a
+| Uentryl of 'a * int
+
+(** {5 Type-safe grammar extension} *)
+
+type ('self, 'a) symbol =
+| Atoken : Tok.t -> ('self, string) symbol
+| Alist1 : ('self, 'a) symbol -> ('self, 'a list) symbol
+| Alist1sep : ('self, 'a) symbol * ('self, _) symbol -> ('self, 'a list) symbol
+| Alist0 : ('self, 'a) symbol -> ('self, 'a list) symbol
+| Alist0sep : ('self, 'a) symbol * ('self, _) symbol -> ('self, 'a list) symbol
+| Aopt : ('self, 'a) symbol -> ('self, 'a option) symbol
+| Aself : ('self, 'self) symbol
+| Anext : ('self, 'self) symbol
+| Aentry : 'a entry -> ('self, 'a) symbol
+| Aentryl : 'a entry * int -> ('self, 'a) symbol
+| Arules : 'a rules list -> ('self, 'a) symbol
+
+and ('self, _, 'r) rule =
+| Stop : ('self, 'r, 'r) rule
+| Next : ('self, 'a, 'r) rule * ('self, 'b) symbol -> ('self, 'b -> 'a, 'r) rule
+
+and ('a, 'r) norec_rule = { norec_rule : 's. ('s, 'a, 'r) rule }
+
+and 'a rules =
+| Rules : ('act, Loc.t -> 'a) norec_rule * 'act -> 'a rules
+
+type 'a production_rule =
+| Rule : ('a, 'act, Loc.t -> 'a) rule * 'act -> 'a production_rule
+
+type 'a single_extend_statment =
+  string option *
+  (** Level *)
+  gram_assoc option *
+  (** Associativity *)
+  'a production_rule list
+  (** Symbol list with the interpretation function *)
+
+type 'a extend_statment =
+  gram_position option *
+  'a single_extend_statment list
diff --git a/intf/genredexpr.mli b/intf/genredexpr.mli
index ff036a13..2df79673 100644
--- a/intf/genredexpr.mli
+++ b/intf/genredexpr.mli
@@ -12,7 +12,9 @@
 
 type 'a red_atom =
   | FBeta
-  | FIota
+  | FMatch
+  | FFix
+  | FCofix
   | FZeta
   | FConst of 'a list
   | FDeltaBut of 'a list
@@ -21,7 +23,9 @@ type 'a red_atom =
 
 type 'a glob_red_flag = {
   rBeta : bool;
-  rIota : bool;
+  rMatch : bool;
+  rFix : bool;
+  rCofix : bool;
   rZeta : bool;
   rDelta : bool; (** true = delta all but rConst; false = delta only on rConst*)
   rConst : 'a list
diff --git a/intf/glob_term.mli b/intf/glob_term.mli
index 81d3e222..b3159c86 100644
--- a/intf/glob_term.mli
+++ b/intf/glob_term.mli
@@ -29,9 +29,14 @@ type cases_pattern =
   | PatCstr of Loc.t * constructor * cases_pattern list * Name.t
       (** [PatCstr(p,C,l,x)] = "|'C' 'l' as 'x'" *)
 
+(** Representation of an internalized (or in other words globalized) term. *)
 type glob_constr =
   | GRef of (Loc.t * global_reference * glob_level list option)
+      (** An identifier that represents a reference to an object defined
+          either in the (global) environment or in the (local) context. *)
   | GVar of (Loc.t * Id.t)
+      (** An identifier that cannot be regarded as "GRef".
+          Bound variables are typically represented this way. *)
   | 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
@@ -39,8 +44,7 @@ type 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]) *)
+      (** [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
diff --git a/intf/misctypes.mli b/intf/misctypes.mli
index a20093bc..1452bbc3 100644
--- a/intf/misctypes.mli
+++ b/intf/misctypes.mli
@@ -31,7 +31,8 @@ and 'constr intro_pattern_action_expr =
   | 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
+  | IntroOrPattern of (Loc.t * 'constr intro_pattern_expr) list list
+  | IntroAndPattern of (Loc.t * 'constr intro_pattern_expr) list
 
 (** Move destination for hypothesis *)
 
@@ -43,7 +44,10 @@ type 'id move_location =
 
 (** Sorts *)
 
-type 'a glob_sort_gen = GProp | GSet | GType of 'a
+type 'a glob_sort_gen =
+  | GProp (** representation of [Prop] literal *)
+  | GSet  (** representation of [Set] literal *)
+  | GType of 'a (** representation of [Type] literal *)
 type sort_info = string Loc.located list
 type level_info = string Loc.located option
 
diff --git a/intf/notation_term.mli b/intf/notation_term.mli
index 3a643b99..1ab9980a 100644
--- a/intf/notation_term.mli
+++ b/intf/notation_term.mli
@@ -42,7 +42,6 @@ type notation_constr =
       (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;
@@ -61,7 +60,7 @@ 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
+  | NtnTypeConstr | NtnTypeOnlyBinder | 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
@@ -74,8 +73,25 @@ type interpretation =
     (Id.t * (subscopes * notation_var_instance_type)) list *
     notation_constr
 
+type reversibility_flag = bool
+
 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;
+}
+
+type grammar_constr_prod_item =
+  | GramConstrTerminal of Tok.t
+  | GramConstrNonTerminal of Extend.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 : Extend.gram_assoc option;
+  notgram_notation : Constrexpr.notation;
+  notgram_prods : grammar_constr_prod_item list list;
+  notgram_typs : notation_var_internalization_type list;
+  notgram_onlyprinting : bool;
 }
diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli
index 6c5e4406..5b5957be 100644
--- a/intf/tacexpr.mli
+++ b/intf/tacexpr.mli
@@ -34,13 +34,19 @@ type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use
 
 type debug = Debug | Info | Off (* for trivial / auto / eauto ... *)
 
-type 'a core_induction_arg =
+type goal_selector =
+  | SelectNth of int
+  | SelectList of (int * int) list
+  | SelectId of Id.t
+  | SelectAll
+
+type 'a core_destruction_arg =
   | ElimOnConstr of 'a
   | ElimOnIdent of Id.t located
   | ElimOnAnonHyp of int
 
-type 'a induction_arg =
-  clear_flag * 'a core_induction_arg
+type 'a destruction_arg =
+  clear_flag * 'a core_destruction_arg
 
 type inversion_kind =
   | SimpleInversion
@@ -62,7 +68,7 @@ type 'id message_token =
   | MsgIdent of 'id
 
 type ('dconstr,'id) induction_clause =
-    'dconstr with_bindings induction_arg *
+    'dconstr with_bindings destruction_arg *
     (intro_pattern_naming_expr located option (* eqn:... *)
     * 'dconstr or_and_intro_pattern_expr located or_var option) (* as ... *)
     * 'id clause_expr option (* in ... *)
@@ -104,6 +110,11 @@ type ml_tactic_name = {
   mltac_tactic : string;
 }
 
+type ml_tactic_entry = {
+  mltac_name : ml_tactic_name;
+  mltac_index : int;
+}
+
 (** Composite types *)
 
 (** In globalize tactics, we need to keep the initial [constr_expr] to recompute
@@ -115,13 +126,14 @@ type open_constr_expr = unit * constr_expr
 type open_glob_constr = unit * glob_constr_and_expr
 
 type binding_bound_vars = Id.Set.t
-type glob_constr_pattern_and_expr = glob_constr_and_expr * constr_pattern
+type glob_constr_pattern_and_expr = binding_bound_vars * glob_constr_and_expr * constr_pattern
+
+type 'a delayed_open = 'a Pretyping.delayed_open =
+  { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma }
 
-type delayed_open_constr_with_bindings =
-    Environ.env -> Evd.evar_map -> Evd.evar_map * Term.constr with_bindings
+type delayed_open_constr_with_bindings = Term.constr with_bindings delayed_open
 
-type delayed_open_constr =
-    Environ.env -> Evd.evar_map -> Evd.evar_map * Term.constr
+type delayed_open_constr = Term.constr delayed_open
 
 type intro_pattern = delayed_open_constr intro_pattern_expr located
 type intro_patterns = delayed_open_constr intro_pattern_expr located list
@@ -132,50 +144,28 @@ type intro_pattern_naming = intro_pattern_naming_expr located
 
 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
+  | TacIntroPattern of evars_flag * 'dtrm intro_pattern_expr located list
   | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list *
       ('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 *
+      bool * 'tacexpr option 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 *
@@ -190,7 +180,6 @@ type 'a gen_atomic_tactic_expr =
 
 constraint 'a = <
     term:'trm;
-    utrm: 'utrm;
     dterm: 'dtrm;
     pattern:'pat;
     constant:'cst;
@@ -202,12 +191,9 @@ constraint 'a = <
 
 (** Possible arguments of a tactic definition *)
 
-and 'a gen_tactic_arg =
-  | TacDynamic     of Loc.t * Dyn.t
+type 'a gen_tactic_arg =
   | 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
@@ -218,7 +204,6 @@ and 'a gen_tactic_arg =
 
 constraint 'a = <
     term:'trm;
-    utrm: 'utrm;
     dterm: 'dtrm;
     pattern:'pat;
     constant:'cst;
@@ -290,14 +275,14 @@ and 'a gen_tactic_expr =
       ('p,'a gen_tactic_expr) match_rule list
   | TacFun of 'a gen_tactic_fun_ast
   | TacArg of 'a gen_tactic_arg located
+  | TacSelect of goal_selector * 'a gen_tactic_expr
   (* For ML extensions *)
-  | TacML of Loc.t * ml_tactic_name * 'l generic_argument list
+  | TacML of Loc.t * ml_tactic_entry * 'a gen_tactic_arg list
   (* For syntax extensions *)
-  | TacAlias of Loc.t * KerName.t * (Id.t * 'l generic_argument) list
+  | TacAlias of Loc.t * KerName.t * 'a gen_tactic_arg list
 
 constraint 'a = <
     term:'t;
-    utrm: 'utrm;
     dterm: 'dtrm;
     pattern:'p;
     constant:'c;
@@ -312,7 +297,6 @@ and 'a gen_tactic_fun_ast =
 
 constraint 'a = <
     term:'t;
-    utrm: 'utrm;
     dterm: 'dtrm;
     pattern:'p;
     constant:'c;
@@ -325,7 +309,6 @@ constraint 'a = <
 (** Globalized tactics *)
 
 type g_trm = glob_constr_and_expr
-type g_utrm = g_trm
 type g_pat = glob_constr_pattern_and_expr
 type g_cst = evaluable_global_reference and_short_name or_var
 type g_ref = ltac_constant located or_var
@@ -333,7 +316,6 @@ type g_nam  = Id.t located
 
 type g_dispatch =  <
     term:g_trm;
-    utrm:g_utrm;
     dterm:g_trm;
     pattern:g_pat;
     constant:g_cst;
@@ -355,7 +337,6 @@ type glob_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
@@ -364,7 +345,6 @@ type r_lev = rlevel
 
 type r_dispatch =  <
     term:r_trm;
-    utrm:r_utrm;
     dterm:r_trm;
     pattern:r_pat;
     constant:r_cst;
@@ -386,34 +366,38 @@ type raw_tactic_arg =
 (** Interpreted tactics *)
 
 type t_trm = Term.constr
-type t_utrm = Glob_term.closed_glob_constr
-type t_pat = glob_constr_pattern_and_expr
-type t_cst = evaluable_global_reference and_short_name
+type t_pat = constr_pattern
+type t_cst = evaluable_global_reference
 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;
+    tacexpr:unit;
     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
+
+(** Traces *)
+
+type ltac_call_kind =
+  | LtacMLCall of glob_tactic_expr
+  | LtacNotationCall of KerName.t
+  | LtacNameCall of ltac_constant
+  | LtacAtomCall of glob_atomic_tactic_expr
+  | LtacVarCall of Id.t * glob_tactic_expr
+  | LtacConstrInterp of Glob_term.glob_constr * Pretyping.ltac_var_map
+
+type ltac_trace = (Loc.t * ltac_call_kind) list
diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli
index 13dde16e..92e4dd61 100644
--- a/intf/vernacexpr.mli
+++ b/intf/vernacexpr.mli
@@ -19,7 +19,6 @@ open Libnames
 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
 
@@ -28,11 +27,11 @@ type class_rawexpr = FunClass | SortClass | RefClass of reference or_by_notation
    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 =
+type goal_selector = Tacexpr.goal_selector =
   | SelectNth of int
+  | SelectList of (int * int) list
   | SelectId of Id.t
   | SelectAll
-  | SelectAllParallel
 
 type goal_identifier = string
 type scope_name = string
@@ -62,7 +61,6 @@ type printable =
   | PrintClasses
   | PrintTypeClasses
   | PrintInstances of reference or_by_notation
-  | PrintLtac of reference
   | PrintCoercions
   | PrintCoercionPaths of class_rawexpr * class_rawexpr
   | PrintCanonicalConversions
@@ -70,7 +68,6 @@ type printable =
   | PrintHint of reference or_by_notation
   | PrintHintGoal
   | PrintHintDbName of string
-  | PrintRewriteHintDbName of string
   | PrintHintDb
   | PrintScopes
   | PrintScope of string
@@ -109,7 +106,7 @@ type showable =
   | ShowTree
   | ShowProofNames
   | ShowIntros of bool
-  | ShowMatch of lident
+  | ShowMatch of reference
   | ShowThesis
 
 type comment =
@@ -121,12 +118,23 @@ type reference_or_constr =
   | HintsReference of reference
   | HintsConstr of constr_expr
 
+type hint_mode =
+  | ModeInput (* No evars *)
+  | ModeNoHeadEvar (* No evar at the head *)
+  | ModeOutput (* Anything *)
+
+type 'a hint_info_gen =
+    { hint_priority : int option;
+      hint_pattern : 'a option }
+
+type hint_info_expr = constr_pattern_expr hint_info_gen
+
 type hints_expr =
-  | HintsResolve of (int option * bool * reference_or_constr) list
+  | HintsResolve of (hint_info_expr * 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
+  | HintsMode of reference * hint_mode list
   | HintsConstructors of reference list
   | HintsExtern of int * constr_expr option * raw_tactic_expr
 
@@ -204,16 +212,14 @@ type one_inductive_expr =
 type proof_expr =
   plident option * (local_binder list * constr_expr * (lident option * recursion_order_expr) option)
 
-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
+  | SetOnlyParsing
+  | SetOnlyPrinting
+  | SetCompatVersion of Flags.compat_version
   | SetFormat of string * string located
 
 type proof_end =
@@ -233,7 +239,32 @@ type section_subset_expr =
   | SsSubstr of section_subset_expr * section_subset_expr
   | SsFwdClose of section_subset_expr
 
-(** Extension identifiers for the VERNAC EXTEND mechanism. *)
+(** Extension identifiers for the VERNAC EXTEND mechanism.
+
+    {b ("Extraction", 0} indicates {b Extraction {i qualid}} command.
+
+    {b ("Extraction", 1} indicates {b Recursive Extraction {i qualid}} command.
+
+    {b ("Extraction", 2)} indicates {b Extraction "{i filename}" {i qualid{_ 1}} ... {i qualid{_ n}}} command.
+
+    {b ("ExtractionLibrary", 0)} indicates {b Extraction Library {i ident}} command.
+
+    {b ("RecursiveExtractionLibrary", 0)} indicates {b Recursive Extraction Library {i ident}} command.
+
+    {b ("SeparateExtraction", 0)} indicates {b Separate Extraction {i qualid{_ 1}} ... {i qualid{_ n}}} command.
+
+    {b ("ExtractionLanguage", 0)} indicates {b Extraction Language Ocaml} or {b Extraction Language Haskell} or {b Extraction Language Scheme} or {b Extraction Language JSON} commands.
+
+    {b ("ExtractionImplicit", 0)} indicates {b Extraction Implicit {i qualid} \[ {i ident{_1}} ... {i ident{_n} } \] } command.
+
+    {b ("ExtractionConstant", 0)} indicates {b Extract Constant {i qualid} => {i string}} command.
+
+    {b ("ExtractionInlinedConstant", 0)} indicates {b Extract Inlined Constant {i qualid} => {i string}} command.
+
+    {b ("ExtractionInductive", 0)} indicates {b Extract Inductive {i qualid} => {i string} [ {i string} ... {string} ] {i optstring}} command.
+
+    {b ("ExtractionBlacklist", 0)} indicates {b Extraction Blacklist {i ident{_1}} ... {i ident{_n}}} command.
+ *)
 type extend_name =
   (** Name of the vernac entry where the tactic is defined, typically found
       after the VERNAC EXTEND statement in the source. *)
@@ -287,20 +318,18 @@ type module_binder = bool option * lident list * module_ast_inl
 type vernac_expr =
   (* Control *)
   | VernacLoad of verbose_flag * string
-  | VernacTime of vernac_list
-  | VernacRedirect of string * vernac_list
+  | VernacTime of vernac_expr located
+  | VernacRedirect of string * vernac_expr located
   | 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 option
-  | VernacBindScope of scope_name * reference or_by_notation list
+  | VernacBindScope of scope_name * class_rawexpr list
   | VernacInfix of obsolete_locality * (lstring * syntax_modifier list) *
       constr_expr * scope_name option
   | VernacNotation of
@@ -324,14 +353,14 @@ type vernac_expr =
   | VernacScheme of (lident option * scheme) list
   | VernacCombinedScheme of lident * lident list
   | VernacUniverse of lident list
-  | VernacConstraint of (lident * Univ.constraint_type * lident) list
+  | VernacConstraint of (glob_level * Univ.constraint_type * glob_level) list
 
   (* Gallina extensions *)
   | VernacBeginSection of lident
   | VernacEndSegment of lident
   | VernacRequire of
-      lreference option * export_flag option * lreference list
-  | VernacImport of export_flag * lreference list
+      reference option * export_flag option * reference list
+  | VernacImport of export_flag * reference list
   | VernacCanonical of reference or_by_notation
   | VernacCoercion of obsolete_locality * reference or_by_notation *
       class_rawexpr * class_rawexpr
@@ -345,12 +374,12 @@ type vernac_expr =
       local_binder list * (* super *)
 	typeclass_constraint * (* instance name, class name, params *)
 	(bool * constr_expr) option * (* props *)
-	int option (* Priority *)
+	hint_info_expr
 
   | VernacContext of local_binder list
 
   | VernacDeclareInstances of
-    reference list * int option (* instance names, priority *)
+    (reference * hint_info_expr) list (* instances names, priorities and patterns *)
 
   | VernacDeclareClass of reference (* inductive or definition name *)
 
@@ -365,7 +394,6 @@ type vernac_expr =
 
   (* Solving *)
 
-  | VernacSolve of goal_selector * int option * raw_tactic_expr * bool
   | VernacSolveExistential of int * constr_expr
 
   (* Auxiliary file and library management *)
@@ -386,8 +414,6 @@ type vernac_expr =
   | 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
@@ -396,10 +422,12 @@ type vernac_expr =
   | 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
+      vernac_argument_status list (* Main arguments status list *) *
+        (Name.t * vernac_implicit_status) list list (* Extra implicit status lists *) *
+      int option (* Number of args to trigger reduction *) *
+        [ `ReductionDontExposeCase | `ReductionNeverUnfold | `Rename |
+          `ExtraScopes | `Assert | `ClearImplicits | `ClearScopes |
+          `DefaultImplicits ] list
   | VernacArgumentsScope of reference or_by_notation *
       scope_name option list
   | VernacReserve of simple_binder list
@@ -409,6 +437,7 @@ type vernac_expr =
       (Conv_oracle.level * reference or_by_notation list) list
   | VernacUnsetOption of Goptions.option_name
   | VernacSetOption of Goptions.option_name * option_value
+  | VernacSetAppendOption of Goptions.option_name * string
   | 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
@@ -421,7 +450,6 @@ type vernac_expr =
   | VernacLocate of locatable
   | VernacRegister of lident * register_kind
   | VernacComments of comment list
-  | VernacNop
 
   (* Stm backdoor *)
   | VernacStm of vernac_expr stm_vernac
@@ -455,9 +483,18 @@ type vernac_expr =
   | VernacPolymorphic of bool * vernac_expr
   | VernacLocal of bool * vernac_expr
 
-and vernac_list = located_vernac_expr list
+and tacdef_body =
+  | TacticDefinition of Id.t Loc.located * raw_tactic_expr  (* indicates that user employed ':=' in Ltac body *)
+  | TacticRedefinition of reference * raw_tactic_expr       (* indicates that user employed '::=' in Ltac body *)
+
+and vernac_implicit_status = Implicit | MaximallyImplicit | NotImplicit
 
-and located_vernac_expr = Loc.t * vernac_expr
+and vernac_argument_status = {
+  name : Name.t;
+  recarg_like : bool;
+  notation_scope : (Loc.t * string) option;
+  implicit_status : vernac_implicit_status;
+}
 
 (* A vernac classifier has to tell if a command:
    vernac_when: has to be executed now (alters the parser) or later
@@ -468,7 +505,7 @@ type vernac_type =
   | VtStartProof of vernac_start
   | VtSideff of vernac_sideff_type
   | VtQed of vernac_qed_type
-  | VtProofStep of bool (* parallelize *)
+  | VtProofStep of proof_step
   | VtProofMode of string
   | VtQuery of vernac_part_of_script * report_with
   | VtStm of vernac_control * vernac_part_of_script
@@ -490,6 +527,13 @@ and vernac_control =
 and opacity_guarantee =
   | GuaranteesOpacity (** Only generates opaque terms at [Qed] *)
   | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*)
+and proof_step = { (* TODO: inline with OCaml 4.03 *)
+  parallel : [ `Yes of solving_tac * anon_abstracting_tac | `No ];
+  proof_block_detection : proof_block_name option
+}
+and solving_tac = bool (* a terminator *)
+and anon_abstracting_tac = bool (* abstracting anonymously its result *)
+and proof_block_name = string (* open type of delimiters *)
 type vernac_when =
   | VtNow
   | VtLater
diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c
index 29e33d34..d5feafbf 100644
--- a/kernel/byterun/coq_fix_code.c
+++ b/kernel/byterun/coq_fix_code.c
@@ -57,7 +57,7 @@ void init_arity () {
     arity[MAKEBLOCK1]=arity[MAKEBLOCK2]=arity[MAKEBLOCK3]=arity[MAKEBLOCK4]=
     arity[MAKEACCU]=arity[CONSTINT]=arity[PUSHCONSTINT]=arity[GRABREC]=
     arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]=
-    arity[BRANCH]=arity[ISCONST]= 1;
+    arity[BRANCH]=arity[ISCONST]=arity[ENSURESTACKCAPACITY]=1;
   /* instruction with two operands */
   arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]=
   arity[ARECONST]=arity[PROJ]=2;
@@ -79,7 +79,7 @@ void * coq_stat_alloc (asize_t sz)
 
 value coq_makeaccu (value i) {
   code_t q;
-  code_t res = coq_stat_alloc(8);
+  code_t res = coq_stat_alloc(2 * sizeof(opcode_t));
   q = res;
   *q++ = VALINSTR(MAKEACCU);
   *q = (opcode_t)Int_val(i);
@@ -91,13 +91,13 @@ value coq_pushpop (value i) {
   int n;
   n = Int_val(i);
   if (n == 0) {
-    res = coq_stat_alloc(4);
+    res = coq_stat_alloc(sizeof(opcode_t));
     *res = VALINSTR(STOP);
     return (value)res;
   }
   else {
     code_t q;
-    res = coq_stat_alloc(12);
+    res = coq_stat_alloc(3 * sizeof(opcode_t));
     q = res;
     *q++ = VALINSTR(POP);
     *q++ = (opcode_t)n;
diff --git a/kernel/byterun/coq_instruct.h b/kernel/byterun/coq_instruct.h
index 8c5ab0ec..d92e85fd 100644
--- a/kernel/byterun/coq_instruct.h
+++ b/kernel/byterun/coq_instruct.h
@@ -14,6 +14,8 @@
 /* Nota: this list of instructions is parsed to produce derived files */
 /* coq_jumptbl.h and copcodes.ml. Instructions should be uppercase    */
 /* and alone on lines starting by two spaces.                         */
+/* If adding an instruction, DON'T FORGET TO UPDATE coq_fix_code.c    */
+/* with the arity of the instruction and maybe coq_tcode_of_code.     */
 
 enum instructions {
   ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, ACC,
@@ -37,6 +39,7 @@ enum instructions {
   GETFIELD0, GETFIELD1, GETFIELD, 
   SETFIELD0, SETFIELD1, SETFIELD,
   PROJ,
+  ENSURESTACKCAPACITY,
   CONST0, CONST1, CONST2, CONST3, CONSTINT,
   PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT,
   ACCUMULATE,
diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c
index dc571699..5dec3b78 100644
--- a/kernel/byterun/coq_interp.c
+++ b/kernel/byterun/coq_interp.c
@@ -22,18 +22,10 @@
 #include "coq_memory.h" 
 #include "coq_values.h" 
 
-/*spiwack : imports support functions for 64-bit integers */
-#include <caml/config.h>
-#ifdef ARCH_INT64_TYPE
-#include "int64_native.h"
-#else
-#include "int64_emul.h"
-#endif
-
 /* spiwack: I append here a few macros for value/number manipulation */
-#define uint32_of_value(val) (((uint32_t)val >> 1))
-#define value_of_uint32(i)   ((value)(((uint32_t)(i) << 1) | 1))
-#define UI64_of_uint32(lo)  ((uint64_t)(I64_literal(0,(uint32_t)(lo))))
+#define uint32_of_value(val) (((uint32_t)(val)) >> 1)
+#define value_of_uint32(i)   ((value)((((uint32_t)(i)) << 1) | 1))
+#define UI64_of_uint32(lo) ((uint64_t)((uint32_t)(lo)))
 #define UI64_of_value(val) (UI64_of_uint32(uint32_of_value(val)))
 /* /spiwack */
 
@@ -84,6 +76,14 @@ sp is a local copy of the global variable extern_sp. */
 #   define print_lint(i)
 #endif
 
+#define CHECK_STACK(num_args) {                                                \
+if (sp - num_args < coq_stack_threshold) {                                     \
+  coq_sp = sp;                                                                 \
+  realloc_coq_stack(num_args + Coq_stack_threshold / sizeof(value));           \
+  sp = coq_sp;                                                                 \
+ }                                                                             \
+}
+
 /* GC interface */
 #define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = coq_env; coq_sp = sp; }
 #define Restore_after_gc { accu = sp[0]; coq_env = sp[1]; sp += 2; }
@@ -206,6 +206,9 @@ value coq_interprete
   sp = coq_sp;
   pc = coq_pc;
   accu = coq_accu;
+
+  CHECK_STACK(0);
+
 #ifdef THREADED_CODE
   goto *(void *)(coq_jumptbl_base + *pc++); /* Jump to the first instruction */
 #else
@@ -362,7 +365,7 @@ value coq_interprete
 	coq_extra_args = *pc - 1;
 	pc = Code_val(accu);
 	coq_env = accu;
-	goto check_stacks;
+	goto check_stack;
       }
       Instruct(APPLY1) {
 	value arg1 = sp[0];
@@ -379,7 +382,7 @@ value coq_interprete
 	pc = Code_val(accu);
 	coq_env = accu;
 	coq_extra_args = 0;
-	goto check_stacks;
+	goto check_stack;
       }
       Instruct(APPLY2) {
 	value arg1 = sp[0];
@@ -394,7 +397,7 @@ value coq_interprete
 	pc = Code_val(accu);
 	coq_env = accu;
 	coq_extra_args = 1;
-	goto check_stacks;
+	goto check_stack;
       }
       Instruct(APPLY3) {
 	value arg1 = sp[0];
@@ -411,17 +414,13 @@ value coq_interprete
 	pc = Code_val(accu);
 	coq_env = accu;
 	coq_extra_args = 2;
-	goto check_stacks;
+	goto check_stack;
       }
       /* Stack checks */
       
-    check_stacks:
-      print_instr("check_stacks");
-      if (sp < coq_stack_threshold) {
-	coq_sp = sp;
-	realloc_coq_stack(Coq_stack_threshold);
-	sp = coq_sp;
-      }
+    check_stack:
+      print_instr("check_stack");
+      CHECK_STACK(0);
       /* We also check for signals */
       if (caml_signals_are_pending) {
 	/* If there's a Ctrl-C, we reset the vm */
@@ -430,6 +429,16 @@ value coq_interprete
       }
       Next;
 
+      Instruct(ENSURESTACKCAPACITY) {
+        print_instr("ENSURESTACKCAPACITY");
+        int size = *pc++;
+        /* CHECK_STACK may trigger here a useless allocation because of the
+        threshold, but check_stack: often does it anyway, so we prefer to
+        factorize the code. */
+        CHECK_STACK(size);
+        Next;
+      }
+
       Instruct(APPTERM) {
 	int nargs = *pc++;
 	int slotsize = *pc;
@@ -444,7 +453,7 @@ value coq_interprete
 	pc = Code_val(accu);
 	coq_env = accu;
 	coq_extra_args += nargs - 1;
-	goto check_stacks;
+	goto check_stack;
       }
       Instruct(APPTERM1) {
 	value arg1 = sp[0];
@@ -453,7 +462,7 @@ value coq_interprete
 	sp[0] = arg1;
 	pc = Code_val(accu);
 	coq_env = accu;
-	goto check_stacks;
+	goto check_stack;
       }
       Instruct(APPTERM2) {
 	value arg1 = sp[0];
@@ -466,7 +475,7 @@ value coq_interprete
 	print_lint(accu);
 	coq_env = accu;
 	coq_extra_args += 1;
-	goto check_stacks;
+	goto check_stack;
       }
       Instruct(APPTERM3) {
 	value arg1 = sp[0];
@@ -480,7 +489,7 @@ value coq_interprete
 	pc = Code_val(accu);
 	coq_env = accu;
 	coq_extra_args += 2;
-	goto check_stacks;
+	goto check_stack;
       }
       
       Instruct(RETURN) {
@@ -511,6 +520,7 @@ value coq_interprete
 	int num_args = Wosize_val(coq_env) - 2;
 	int i;
 	print_instr("RESTART");
+        CHECK_STACK(num_args);
 	sp -= num_args;
 	for (i = 0; i < num_args; i++) sp[i] = Field(coq_env, i + 2);
 	coq_env = Field(coq_env, 1);
@@ -547,6 +557,7 @@ value coq_interprete
 	  pc++;/* On saute le Restart */
 	} else {
 	  if (coq_extra_args < rec_pos) {
+            /* Partial application */
 	    mlsize_t num_args, i;
 	    num_args = 1 + coq_extra_args; /* arg1 + extra args */
 	    Alloc_small(accu, num_args + 2, Closure_tag); 
@@ -561,10 +572,10 @@ value coq_interprete
 	  } else {
 	    /* The recursif argument is an accumulator */
 	    mlsize_t num_args, i;
-	    /* Construction of partially applied PF */
+	    /* Construction of fixpoint applied to its [rec_pos-1] first arguments */
 	    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];
+	    Field(accu, 1) = coq_env; // We store the fixpoint in the first field
+	    for (i = 0; i < rec_pos; i++) Field(accu, i + 2) = sp[i]; // Storing args
 	    Code_val(accu) = pc;
 	    sp += rec_pos;
 	    *--sp = accu;
@@ -870,29 +881,7 @@ value coq_interprete
        	sp++;
 	Next; 
       }
-  
-      /* *sp = accu;
-	* Netoyage des cofix *
-        size = Wosize_val(accu);
-        for (i = 2; i < size; i++) {
- 	  accu = Field(*sp, i);
-          if (IS_EVALUATED_COFIX(accu)) {
-            size_aux = Wosize_val(accu);
-            *--sp = accu;
-	    Alloc_small(accu, size_aux, Accu_tag);
-	    for(j = 0; j < size_aux; j++) Field(accu, j) = Field(*sp, j);
-	    *sp = accu;
-	    Alloc_small(accu, 1, ATOM_COFIX_TAG);
-	    Field(accu, 0) = Field(Field(*sp, 1), 0);
-	    caml_modify(&Field(*sp, 1), accu);
-	    accu = *sp; sp++;
-            caml_modify(&Field(*sp, i), accu);
-	  }
-	}
-	sp++;
-	Next; 
-	} */
-      
+       
       Instruct(SETFIELD){
 	print_instr("SETFIELD");
 	caml_modify(&Field(accu, *pc),*sp);
@@ -911,10 +900,12 @@ value coq_interprete
 	  Alloc_small(block, 2, ATOM_PROJ_TAG);
 	  Field(block, 0) = Field(coq_global_data, *pc);
 	  Field(block, 1) = accu;
-	  /* Create accumulator */
-	  Alloc_small(accu, 2, Accu_tag);
-	  Code_val(accu) = accumulate;
-	  Field(accu, 1) = block;
+          accu = block;
+          /* Create accumulator */
+          Alloc_small(block, 2, Accu_tag);
+          Code_val(block) = accumulate;
+          Field(block, 1) = accu;
+          accu = block;
 	} else {
 	    accu = Field(accu, *pc++);
 	}
@@ -984,28 +975,31 @@ value coq_interprete
       }  
       Instruct(MAKESWITCHBLOCK) {
 	print_instr("MAKESWITCHBLOCK");
-	*--sp = accu;
-	accu = Field(accu,1);
+	*--sp = accu; // Save matched block on stack
+	accu = Field(accu,1); // Save atom to accu register
 	switch (Tag_val(accu)) {
-	case ATOM_COFIX_TAG: 
+	case ATOM_COFIX_TAG: // We are forcing a cofix
 	  {
 	    mlsize_t i, nargs;
 	    print_instr("COFIX_TAG");
 	    sp-=2;
 	    pc++;
+            // Push the return address
 	    sp[0] = (value) (pc + *pc);
 	    sp[1] = coq_env;
-	    coq_env = Field(accu,0);
-	    accu = sp[2];
-	    sp[2] = Val_long(coq_extra_args);
-	    nargs = Wosize_val(accu) - 2;
+	    coq_env = Field(accu,0); // Pointer to suspension
+	    accu = sp[2]; // Save accumulator to accu register
+	    sp[2] = Val_long(coq_extra_args); // Push number of args for return
+	    nargs = Wosize_val(accu) - 2; // Number of args = size of accumulator - 1 (accumulator code) - 1 (atom)
+            // Push arguments to stack
+            CHECK_STACK(nargs+1);
 	    sp -= nargs;
-	    for (i = 0; i < nargs; i++) sp[i] = Field(accu, i + 2);
-	    *--sp = accu;
+	    for (i = 0; i < nargs; i++) sp[i] = Field(accu, i + 2); 
+	    *--sp = accu; // Last argument is the pointer to the suspension
 	    print_lint(nargs);
 	    coq_extra_args = nargs;
-	    pc = Code_val(coq_env);
-	    goto check_stacks;
+	    pc = Code_val(coq_env); // Trigger evaluation
+	    goto check_stack;
 	  }
 	case ATOM_COFIXEVALUATED_TAG: 
 	  {
@@ -1030,7 +1024,7 @@ value coq_interprete
 	    annot = *pc++;
 	    sz = *pc++;
 	    *--sp=Field(coq_global_data, annot);
-	    /* On sauve la pile */
+	    /* We save the stack */
 	    if (sz == 0) accu = Atom(0);
 	    else {
 	      Alloc_small(accu, sz, Default_tag);
@@ -1041,17 +1035,17 @@ value coq_interprete
 	      }
 	    }
 	    *--sp = accu;
-	    /* On cree le zipper switch */
+	    /* We create the switch zipper */
 	    Alloc_small(accu, 5, Default_tag);
 	    Field(accu, 0) =  (value)typlbl; Field(accu, 1) = (value)swlbl; 
 	    Field(accu, 2) = sp[1]; Field(accu, 3) = sp[0]; 
 	    Field(accu, 4) = coq_env;
 	    sp++;sp[0] = accu;
-	    /* On cree l'atome */
+	    /* We create the atom */
 	    Alloc_small(accu, 2, ATOM_SWITCH_TAG);
 	    Field(accu, 0) = sp[1]; Field(accu, 1) = sp[0];
 	    sp++;sp[0] = accu;
-	    /* On cree l'accumulateur */
+	    /* We create the accumulator */
 	    Alloc_small(accu, 2, Accu_tag);
 	    Code_val(accu) = accumulate; 
 	    Field(accu,1) = *sp++;
@@ -1201,8 +1195,8 @@ value coq_interprete
         print_instr("MULCINT31");
 	uint64_t p;
         /*accu = 2v+1, *sp=2w+1 ==> p = 2v*w */
-        p = I64_mul (UI64_of_value (accu), UI64_of_uint32 ((*sp++)^1));
-	if ( I64_is_zero(p) ) {
+        p = UI64_of_value (accu) * UI64_of_uint32 ((*sp++)^1);
+	if (p == 0) {
 	  accu = (value)1;
 	}
 	else {
@@ -1211,8 +1205,8 @@ value coq_interprete
 	     of the non-constant constructor is then 1 */
 	  Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */
 	  /*unsigned shift*/
-	  Field(accu, 0) = (value)(I64_lsr(p,31)|1) ;  /*higher part*/
-	  Field(accu, 1) = (value)(I64_to_int32(p)|1); /*lower part*/
+	  Field(accu, 0) = (value)((p >> 31)|1) ;  /*higher part*/
+	  Field(accu, 1) = (value)((uint32_t)p|1); /*lower part*/
 	}
 	Next;
       }
@@ -1224,19 +1218,20 @@ value coq_interprete
                     int62 by the int31 */
         uint64_t bigint;
         bigint = UI64_of_value(accu);
-        bigint = I64_or(I64_lsl(bigint, 31),UI64_of_value(*sp++));
+        bigint = (bigint << 31) | UI64_of_value(*sp++);
         uint64_t divisor;
         divisor = UI64_of_value(*sp++);
         Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */
-        if (I64_is_zero (divisor)) {
+        if (divisor == 0) {
           Field(accu, 0) = 1; /* 2*0+1 */
           Field(accu, 1) = 1; /* 2*0+1 */
 	}
 	else {
 	  uint64_t quo, mod;
-          I64_udivmod(bigint, divisor, &quo, &mod);
-          Field(accu, 0) = value_of_uint32(I64_to_int32(quo));
-	  Field(accu, 1) = value_of_uint32(I64_to_int32(mod));
+	  quo = bigint / divisor;
+	  mod = bigint % divisor;
+          Field(accu, 0) = value_of_uint32((uint32_t)(quo));
+	  Field(accu, 1) = value_of_uint32((uint32_t)(mod));
 	}
 	Next;
       }
@@ -1462,26 +1457,32 @@ value coq_push_val(value v) {
 
 value coq_push_arguments(value args) {
   int nargs,i;
+  value * sp = coq_sp;
   nargs = Wosize_val(args) - 2;
+  CHECK_STACK(nargs);
   coq_sp -= nargs;
   print_instr("push_args");print_int(nargs);
   for(i = 0; i < nargs; i++) coq_sp[i] = Field(args, i+2);
   return Val_unit;
 }
 
-value coq_push_vstack(value stk) {
+value coq_push_vstack(value stk, value max_stack_size) {
   int len,i;
+  value * sp = coq_sp;
   len = Wosize_val(stk);
+  CHECK_STACK(len);
   coq_sp -= len;
   print_instr("push_vstack");print_int(len);
    for(i = 0; i < len; i++) coq_sp[i] = Field(stk,i);
+  sp = coq_sp;
+  CHECK_STACK(uint32_of_value(max_stack_size));
   return Val_unit;
 }
 
 value  coq_interprete_ml(value tcode, value a, value e, value ea) {
   print_instr("coq_interprete");
   return coq_interprete((code_t)tcode, a, e, Long_val(ea));
-   print_instr("end coq_interprete");
+  print_instr("end coq_interprete");
 }
 
 value coq_eval_tcode (value tcode, value e) {
diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c
index c9bcdc32..45cfae50 100644
--- a/kernel/byterun/coq_memory.c
+++ b/kernel/byterun/coq_memory.c
@@ -130,6 +130,7 @@ value init_coq_vm(value unit) /* ML */
   return Val_unit;;
 }
 
+/* [required_space] is a size in words */
 void realloc_coq_stack(asize_t required_space)
 {
   asize_t size;
diff --git a/kernel/byterun/int64_emul.h b/kernel/byterun/int64_emul.h
deleted file mode 100644
index 86bee72e..00000000
--- a/kernel/byterun/int64_emul.h
+++ /dev/null
@@ -1,270 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
-/*                                                                     */
-/*  Copyright 2002 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../LICENSE.     */
-/*                                                                     */
-/***********************************************************************/
-
-/* Software emulation of 64-bit integer arithmetic, for C compilers
-   that do not support it.  */
-
-#ifndef CAML_INT64_EMUL_H
-#define CAML_INT64_EMUL_H
-
-#include <math.h>
-
-#ifdef ARCH_BIG_ENDIAN
-#define I64_literal(hi,lo) { hi, lo }
-#else
-#define I64_literal(hi,lo) { lo, hi }
-#endif
-
-/* Unsigned comparison */
-static int I64_ucompare(uint64 x, uint64 y)
-{
-  if (x.h > y.h) return 1;
-  if (x.h < y.h) return -1;
-  if (x.l > y.l) return 1;
-  if (x.l < y.l) return -1;
-  return 0;
-}
-
-#define I64_ult(x, y) (I64_ucompare(x, y) < 0)
-
-/* Signed comparison */
-static int I64_compare(int64 x, int64 y)
-{
-  if ((int32)x.h > (int32)y.h) return 1;
-  if ((int32)x.h < (int32)y.h) return -1;
-  if (x.l > y.l) return 1;
-  if (x.l < y.l) return -1;
-  return 0;
-}
-
-/* Negation */
-static int64 I64_neg(int64 x)
-{
-  int64 res;
-  res.l = -x.l;
-  res.h = ~x.h;
-  if (res.l == 0) res.h++;
-  return res;
-}
-
-/* Addition */
-static int64 I64_add(int64 x, int64 y)
-{
-  int64 res;
-  res.l = x.l + y.l;
-  res.h = x.h + y.h;
-  if (res.l < x.l) res.h++;
-  return res;
-}
-
-/* Subtraction */
-static int64 I64_sub(int64 x, int64 y)
-{
-  int64 res;
-  res.l = x.l - y.l;
-  res.h = x.h - y.h;
-  if (x.l < y.l) res.h--;
-  return res;
-}
-
-/* Multiplication */
-static int64 I64_mul(int64 x, int64 y)
-{
-  int64 res;
-  uint32 prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF);
-  uint32 prod10 = (x.l >> 16) * (y.l & 0xFFFF);
-  uint32 prod01 = (x.l & 0xFFFF) * (y.l >> 16);
-  uint32 prod11 = (x.l >> 16) * (y.l >> 16);
-  res.l = prod00;
-  res.h = prod11 + (prod01 >> 16) + (prod10 >> 16);
-  prod01 = prod01 << 16; res.l += prod01; if (res.l < prod01) res.h++;
-  prod10 = prod10 << 16; res.l += prod10; if (res.l < prod10) res.h++;
-  res.h += x.l * y.h + x.h * y.l;
-  return res;
-}
-
-#define I64_is_zero(x) (((x).l | (x).h) == 0)
-
-#define I64_is_negative(x) ((int32) (x).h < 0)
-
-/* Bitwise operations */
-static int64 I64_and(int64 x, int64 y)
-{
-  int64 res;
-  res.l = x.l & y.l;
-  res.h = x.h & y.h;
-  return res;
-}
-
-static int64 I64_or(int64 x, int64 y)
-{
-  int64 res;
-  res.l = x.l | y.l;
-  res.h = x.h | y.h;
-  return res;
-}
-
-static int64 I64_xor(int64 x, int64 y)
-{
-  int64 res;
-  res.l = x.l ^ y.l;
-  res.h = x.h ^ y.h;
-  return res;
-}
-
-/* Shifts */
-static int64 I64_lsl(int64 x, int s)
-{
-  int64 res;
-  s = s & 63;
-  if (s == 0) return x;
-  if (s < 32) {
-    res.l = x.l << s;
-    res.h = (x.h << s) | (x.l >> (32 - s));
-  } else {
-    res.l = 0;
-    res.h = x.l << (s - 32);
-  }
-  return res;
-}
-
-static int64 I64_lsr(int64 x, int s)
-{
-  int64 res;
-  s = s & 63;
-  if (s == 0) return x;
-  if (s < 32) {
-    res.l = (x.l >> s) | (x.h << (32 - s));
-    res.h = x.h >> s;
-  } else {
-    res.l = x.h >> (s - 32);
-    res.h = 0;
-  }
-  return res;
-}
-
-static int64 I64_asr(int64 x, int s)
-{
-  int64 res;
-  s = s & 63;
-  if (s == 0) return x;
-  if (s < 32) {
-    res.l = (x.l >> s) | (x.h << (32 - s));
-    res.h = (int32) x.h >> s;
-  } else {
-    res.l = (int32) x.h >> (s - 32);
-    res.h = (int32) x.h >> 31;
-  }
-  return res;
-}
-
-/* Division and modulus */
-
-#define I64_SHL1(x) x.h = (x.h << 1) | (x.l >> 31); x.l <<= 1
-#define I64_SHR1(x) x.l = (x.l >> 1) | (x.h << 31); x.h >>= 1
-
-static void I64_udivmod(uint64 modulus, uint64 divisor,
-                        uint64 * quo, uint64 * mod)
-{
-  int64 quotient, mask;
-  int cmp;
-
-  quotient.h = 0; quotient.l = 0;
-  mask.h = 0; mask.l = 1;
-  while ((int32) divisor.h >= 0) {
-    cmp = I64_ucompare(divisor, modulus);
-    I64_SHL1(divisor);
-    I64_SHL1(mask);
-    if (cmp >= 0) break;
-  }
-  while (mask.l | mask.h) {
-    if (I64_ucompare(modulus, divisor) >= 0) {
-      quotient.h |= mask.h; quotient.l |= mask.l;
-      modulus = I64_sub(modulus, divisor);
-    }
-    I64_SHR1(mask);
-    I64_SHR1(divisor);
-  }
-  *quo = quotient;
-  *mod = modulus;
-}
-
-static int64 I64_div(int64 x, int64 y)
-{
-  int64 q, r;
-  int32 sign;
-
-  sign = x.h ^ y.h;
-  if ((int32) x.h < 0) x = I64_neg(x);
-  if ((int32) y.h < 0) y = I64_neg(y);
-  I64_udivmod(x, y, &q, &r);
-  if (sign < 0) q = I64_neg(q);
-  return q;
-}
-
-static int64 I64_mod(int64 x, int64 y)
-{
-  int64 q, r;
-  int32 sign;
-
-  sign = x.h;
-  if ((int32) x.h < 0) x = I64_neg(x);
-  if ((int32) y.h < 0) y = I64_neg(y);
-  I64_udivmod(x, y, &q, &r);
-  if (sign < 0) r = I64_neg(r);
-  return r;
-}
-
-/* Coercions */
-
-static int64 I64_of_int32(int32 x)
-{
-  int64 res;
-  res.l = x;
-  res.h = x >> 31;
-  return res;
-}
-
-#define I64_to_int32(x) ((int32) (x).l)
-
-/* Note: we assume sizeof(intnat) = 4 here, which is true otherwise
-   autoconfiguration would have selected native 64-bit integers */
-#define I64_of_intnat I64_of_int32
-#define I64_to_intnat I64_to_int32
-
-static double I64_to_double(int64 x)
-{
-  double res;
-  int32 sign = x.h;
-  if (sign < 0) x = I64_neg(x);
-  res = ldexp((double) x.h, 32) + x.l;
-  if (sign < 0) res = -res;
-  return res;
-}
-
-static int64 I64_of_double(double f)
-{
-  int64 res;
-  double frac, integ;
-  int neg;
-
-  neg = (f < 0);
-  f = fabs(f);
-  frac = modf(ldexp(f, -32), &integ);
-  res.h = (uint32) integ;
-  res.l = (uint32) ldexp(frac, 32);
-  if (neg) res = I64_neg(res);
-  return res;
-}
-
-#endif /* CAML_INT64_EMUL_H */
diff --git a/kernel/byterun/int64_native.h b/kernel/byterun/int64_native.h
deleted file mode 100644
index 657d0a07..00000000
--- a/kernel/byterun/int64_native.h
+++ /dev/null
@@ -1,48 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
-/*                                                                     */
-/*  Copyright 2002 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../LICENSE.     */
-/*                                                                     */
-/***********************************************************************/
-
-/* Wrapper macros around native 64-bit integer arithmetic,
-   so that it has the same interface as the software emulation
-   provided in int64_emul.h */
-
-#ifndef CAML_INT64_NATIVE_H
-#define CAML_INT64_NATIVE_H
-
-#define I64_literal(hi,lo) ((int64_t)(hi) << 32 | (lo))
-#define I64_compare(x,y) (((x) > (y)) - ((x) < (y)))
-#define I64_ult(x,y) ((uint64_t)(x) < (uint64_t)(y))
-#define I64_neg(x) (-(x))
-#define I64_add(x,y) ((x) + (y))
-#define I64_sub(x,y) ((x) - (y))
-#define I64_mul(x,y) ((x) * (y))
-#define I64_is_zero(x) ((x) == 0)
-#define I64_is_negative(x) ((x) < 0)
-#define I64_div(x,y) ((x) / (y))
-#define I64_mod(x,y) ((x) % (y))
-#define I64_udivmod(x,y,quo,rem) \
-  (*(rem) = (uint64_t)(x) % (uint64_t)(y), \
-   *(quo) = (uint64_t)(x) / (uint64_t)(y))
-#define I64_and(x,y) ((x) & (y))
-#define I64_or(x,y) ((x) | (y))
-#define I64_xor(x,y) ((x) ^ (y))
-#define I64_lsl(x,y) ((x) << (y))
-#define I64_asr(x,y) ((x) >> (y))
-#define I64_lsr(x,y) ((uint64_t)(x) >> (y))
-#define I64_to_intnat(x) ((intnat) (x))
-#define I64_of_intnat(x) ((intnat) (x))
-#define I64_to_int32(x) ((int32_t) (x))
-#define I64_of_int32(x) ((int64_t) (x))
-#define I64_to_double(x) ((double)(x))
-#define I64_of_double(x) ((int64_t)(x))
-
-#endif /* CAML_INT64_NATIVE_H */
diff --git a/kernel/closure.ml b/kernel/cClosure.ml
index 2ba80d83..fe9ec579 100644
--- a/kernel/closure.ml
+++ b/kernel/cClosure.ml
@@ -19,7 +19,7 @@
 (* This file implements a lazy reduction for the Calculus of Inductive
    Constructions *)
 
-open Errors
+open CErrors
 open Util
 open Pp
 open Names
@@ -37,17 +37,20 @@ let delta = ref 0
 let eta = ref 0
 let zeta = ref 0
 let evar = ref 0
-let iota = ref 0
+let nb_match = ref 0
+let fix = ref 0
+let cofix = ref 0
 let prune = ref 0
 
 let reset () =
-  beta := 0; delta := 0; zeta := 0; evar := 0; iota := 0; evar := 0;
-  prune := 0
+  beta := 0; delta := 0; zeta := 0; evar := 0; nb_match := 0; fix := 0;
+  cofix := 0; evar := 0; prune := 0
 
 let stop() =
-  msg_debug (str "[Reds: beta=" ++ int !beta ++ str" delta=" ++ int !delta ++
+  Feedback.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 ++
+	 int !evar ++ str" match=" ++ int !nb_match ++ str" fix=" ++ int !fix ++
+         str " cofix=" ++ int !cofix ++ str" prune=" ++ int !prune ++
 	 str"]")
 
 let incr_cnt red cnt =
@@ -78,7 +81,9 @@ module type RedFlagsSig = sig
   val fBETA : red_kind
   val fDELTA : red_kind
   val fETA : red_kind
-  val fIOTA : red_kind
+  val fMATCH : red_kind
+  val fFIX : red_kind
+  val fCOFIX : red_kind
   val fZETA : red_kind
   val fCONST : constant -> red_kind
   val fVAR : Id.t -> red_kind
@@ -103,14 +108,19 @@ module RedFlags = (struct
     r_eta : bool;
     r_const : transparent_state;
     r_zeta : bool;
-    r_iota : bool }
+    r_match : bool;
+    r_fix : bool;
+    r_cofix : bool }
 
-  type red_kind = BETA | DELTA | ETA | IOTA | ZETA
+  type red_kind = BETA | DELTA | ETA | MATCH | FIX
+              | COFIX | ZETA
 	      | CONST of constant | VAR of Id.t
   let fBETA = BETA
   let fDELTA = DELTA
   let fETA = ETA
-  let fIOTA = IOTA
+  let fMATCH = MATCH
+  let fFIX = FIX
+  let fCOFIX = COFIX
   let fZETA = ZETA
   let fCONST kn  = CONST kn
   let fVAR id  = VAR id
@@ -120,7 +130,9 @@ module RedFlags = (struct
     r_eta = false;
     r_const = all_opaque;
     r_zeta = false;
-    r_iota = false }
+    r_match = false;
+    r_fix = false;
+    r_cofix = false }
 
   let red_add red = function
     | BETA -> { red with r_beta = true }
@@ -129,7 +141,9 @@ module RedFlags = (struct
     | CONST kn ->
 	let (l1,l2) = red.r_const in
 	{ red with r_const = l1, Cpred.add kn l2 }
-    | IOTA -> { red with r_iota = true }
+    | MATCH -> { red with r_match = true }
+    | FIX -> { red with r_fix = true }
+    | COFIX -> { red with r_cofix = true }
     | ZETA -> { red with r_zeta = true }
     | VAR id ->
 	let (l1,l2) = red.r_const in
@@ -140,9 +154,11 @@ module RedFlags = (struct
     | ETA -> { red with r_eta = false }
     | DELTA -> { red with r_delta = false }
     | CONST kn ->
- 	let (l1,l2) = red.r_const in
+	let (l1,l2) = red.r_const in
 	{ red with r_const = l1, Cpred.remove kn l2 }
-    | IOTA -> { red with r_iota = false }
+    | MATCH -> { red with r_match = false }
+    | FIX -> { red with r_fix = false }
+    | COFIX -> { red with r_cofix = false }
     | ZETA -> { red with r_zeta = false }
     | VAR id ->
 	let (l1,l2) = red.r_const in
@@ -165,11 +181,13 @@ module RedFlags = (struct
 	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
+    | MATCH -> incr_cnt red.r_match nb_match
+    | FIX -> incr_cnt red.r_fix fix
+    | COFIX -> incr_cnt red.r_cofix cofix
     | DELTA -> (* Used for Rel/Var defined in context *)
 	incr_cnt red.r_delta delta
 
-  let red_projection red p = 
+  let red_projection red p =
     if Projection.unfolded p then true
     else red_set red (fCONST (Projection.constant p))
 
@@ -177,15 +195,20 @@ end : RedFlagsSig)
 
 open RedFlags
 
-let betadeltaiota = mkflags [fBETA;fDELTA;fZETA;fIOTA]
-let betadeltaiotanolet = mkflags [fBETA;fDELTA;fIOTA]
-let betaiota = mkflags [fBETA;fIOTA]
+let all = mkflags [fBETA;fDELTA;fZETA;fMATCH;fFIX;fCOFIX]
+let allnolet = mkflags [fBETA;fDELTA;fMATCH;fFIX;fCOFIX]
 let beta = mkflags [fBETA]
-let betaiotazeta = mkflags [fBETA;fIOTA;fZETA]
+let betadeltazeta = mkflags [fBETA;fDELTA;fZETA]
+let betaiota = mkflags [fBETA;fMATCH;fFIX;fCOFIX]
+let betaiotazeta = mkflags [fBETA;fMATCH;fFIX;fCOFIX;fZETA]
+let betazeta = mkflags [fBETA;fZETA]
+let delta = mkflags [fDELTA]
+let zeta = mkflags [fZETA]
+let nored = no_red
 
 (* Removing fZETA for finer behaviour would break many developments *)
-let unfold_side_flags = [fBETA;fIOTA;fZETA]
-let unfold_side_red = mkflags [fBETA;fIOTA;fZETA]
+let unfold_side_flags = [fBETA;fMATCH;fFIX;fCOFIX;fZETA]
+let unfold_side_red = mkflags [fBETA;fMATCH;fFIX;fCOFIX;fZETA]
 let unfold_red kn =
   let flag = match kn with
     | EvalVarRef id -> fVAR id
@@ -215,7 +238,7 @@ 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
@@ -238,18 +261,18 @@ type 'a infos_cache = {
   i_rels : constr option array;
   i_tab : 'a KeyTable.t }
 
-and 'a infos = { 
+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 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
+open Context.Named.Declaration
+
+let assoc_defined id env = match Environ.lookup_named id env with
+| LocalDef (_, c, _) -> c
+| _ -> raise Not_found
 
 let ref_value_cache ({i_cache = cache} as infos)  ref =
   try
@@ -266,7 +289,7 @@ let ref_value_cache ({i_cache = cache} as infos)  ref =
             | None -> raise Not_found
             | Some t -> lift n t
             end
-	| VarKey id -> assoc_defined id (named_context cache.i_env)
+	| VarKey id -> assoc_defined id cache.i_env
 	| ConstKey cst -> constant_value_in cache.i_env cst
     in
     let v = cache.i_repr infos body in
@@ -285,16 +308,17 @@ let defined_rels flags env =
   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
+  let open Context.Rel.Declaration in
+  let iter i = function
+    | LocalAssum _ -> ()
+    | LocalDef (_,b,_) -> Array.unsafe_set ans i (Some b)
   in
   let () = List.iteri iter ctx in
   ans
 (*  else (0,[])*)
 
 let create mk_cl flgs env evars =
-  let cache = 
+  let cache =
     { i_repr = mk_cl;
       i_env = env;
       i_sigma = evars;
@@ -346,7 +370,6 @@ and fterm =
   | FProj of projection * fconstr
   | FFix of fixpoint * fconstr subs
   | FCoFix of cofixpoint * 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
@@ -361,6 +384,7 @@ let set_norm v = v.norm <- Norm
 let is_val v = match v.norm with Norm -> true | _ -> false
 
 let mk_atom c = {norm=Norm;term=FAtom c}
+let mk_red f = {norm=Red;term=f}
 
 (* Could issue a warning if no is still Red, pointing out that we loose
    sharing. *)
@@ -376,7 +400,6 @@ 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
@@ -569,10 +592,6 @@ let rec to_constr constr_fun lfts v =
     | 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,
-		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,
@@ -646,13 +665,10 @@ let rec zip m stk =
   match stk with
     | [] -> m
     | Zapp args :: s -> zip {norm=neutr m.norm; term=FApp(m, args)} s
-    | Zcase(ci,p,br)::s ->
-        let t = 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 -> 
+    | 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)
@@ -731,7 +747,7 @@ let rec get_args 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 _ | ZcaseT _ | Zproj _ 
+  | (Zapp _ | Zfix _ | ZcaseT _ | Zproj _
 	| Zshift _ | Zupdate _ as e) :: s ->
       e :: eta_expand_stack s
   | [] ->
@@ -759,7 +775,7 @@ let rec try_drop_parameters depth n argstk =
           let aft = Array.sub args n (q-n) in
           reloc_rargs depth (append_stack aft s)
     | Zshift(k)::s -> try_drop_parameters (depth-k) n s
-    | [] -> 
+    | [] ->
 	if Int.equal n 0 then []
 	else raise Not_found
     | _ -> assert false
@@ -768,23 +784,23 @@ let rec try_drop_parameters depth n argstk =
 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) *) 
+  (* 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")
 
 (** [eta_expand_ind_stack env ind c s t] computes stacks corresponding
-    to the conversion of the eta expansion of t, considered as an inhabitant 
+    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 
+    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 -> 
+	mib.Declarations.mind_finite == Decl_kinds.BiFinite ->
 	(* (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
@@ -794,12 +810,12 @@ let eta_expand_ind_stack env ind m s (f, s') =
       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]	
+	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 -> 
+  | Zapp args :: s ->
       let q = Array.length args in
 	if n >= q then project_nth_arg (n - q) s
 	else (* n < q *) args.(n)
@@ -842,7 +858,6 @@ let rec knh info m stk =
     | FCLOS(t,e) -> knht info e t (zupdate m stk)
     | FLOCKED -> assert false
     | 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
@@ -855,7 +870,7 @@ let rec knh info m stk =
           (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, 
+	     knh info c (Zproj (pb.Declarations.proj_npars, pb.Declarations.proj_arg,
 				Projection.constant p)
 			 :: zupdate m stk))
 	else (m,stk)
@@ -902,29 +917,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),u) when red_set info.i_flags fIOTA ->
+  | FConstruct((ind,c),u) ->
+     let use_match = red_set info.i_flags fMATCH in
+     let use_fix = red_set info.i_flags fFIX in
+     if use_match || use_fix then
       (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) ->
+        | (depth, args, ZcaseT(ci,_,br,e)::s) when use_match ->
             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) ->
+        | (_, cargs, Zfix(fx,par)::s) when use_fix ->
             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) ->
+	| (depth, args, Zproj (n, m, cst)::s) when use_match ->
 	    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 ->
+     else (m,stk)
+  | FCoFix _ when red_set info.i_flags fCOFIX ->
       (match strip_update_shift_app m stk with
-          (_, args, (((Zcase _|ZcaseT _|Zproj _)::_) as stk')) ->
+          (_, args, (((ZcaseT _|Zproj _)::_) as stk')) ->
             let (fxe,fxbd) = contract_fix_vect m.term in
             knit info fxe fxbd (args@stk')
         | (_,args,s) -> (m,args@s))
@@ -953,15 +968,12 @@ let rec zip_term zfun m stk =
     | [] -> m
     | Zapp args :: s ->
         zip_term zfun (mkApp(m, Array.map zfun args)) s
-    | 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 
+    | 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
@@ -1041,18 +1053,17 @@ 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 = 
+let infos_with_reds infos reds =
   { infos with i_flags = reds }
 
-let unfold_reference info key = 
+let unfold_reference info key =
   match key with
   | ConstKey (kn,_) ->
     if red_set info.i_flags (fCONST kn) then
-      ref_value_cache info key  
+      ref_value_cache info key
     else None
-  | VarKey i -> 
+  | 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/cClosure.mli
index 4b8f8722..077756ac 100644
--- a/kernel/closure.mli
+++ b/kernel/cClosure.mli
@@ -41,8 +41,10 @@ module type RedFlagsSig = sig
   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
+  (** The fETA flag is never used by the kernel reduction but pretyping does *)
+  val fMATCH : red_kind
+  val fFIX : red_kind
+  val fCOFIX : red_kind
   val fZETA : red_kind
   val fCONST : constant -> red_kind
   val fVAR : Id.t -> red_kind
@@ -64,7 +66,7 @@ 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
@@ -73,11 +75,18 @@ end
 module RedFlags : RedFlagsSig
 open RedFlags
 
-val beta               : reds
-val betaiota           : reds
-val betadeltaiota      : reds
-val betaiotazeta       : reds
-val betadeltaiotanolet : reds
+(* These flags do not contain eta *)
+val all               : reds
+val allnolet          : reds
+val beta              : reds
+val betadeltazeta     : reds
+val betaiota          : reds
+val betaiotazeta      : reds
+val betazeta          : reds
+val delta             : reds
+val zeta              : reds
+val nored             : reds
+
 
 val unfold_side_red : reds
 val unfold_red : evaluable_global_reference -> reds
@@ -86,7 +95,7 @@ val unfold_red : evaluable_global_reference -> reds
 type table_key = constant puniverses tableKey
 
 type 'a infos_cache
-type 'a infos = { 
+type 'a infos = {
   i_flags : reds;
   i_cache : 'a infos_cache }
 
@@ -119,7 +128,6 @@ type fterm =
   | FProj of projection * fconstr
   | FFix of fixpoint * fconstr subs
   | FCoFix of cofixpoint * 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
@@ -136,7 +144,6 @@ 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
@@ -166,6 +173,9 @@ val inject : constr -> fconstr
 (** mk_atom: prevents a term from being evaluated *)
 val mk_atom : constr -> fconstr
 
+(** mk_red: makes a reducible term (used in newring) *)
+val mk_red : fterm -> fconstr
+
 val fterm_of : fconstr -> fterm
 val term_of_fconstr : fconstr -> constr
 val destFLambda :
@@ -194,16 +204,16 @@ 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 
+(** [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 
+    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 -> 
+val eta_expand_ind_stack : env -> inductive -> fconstr -> stack ->
    (fconstr * stack) -> stack * stack
 
 (** Conversion auxiliary functions to do step by step normalisation *)
diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml
index f9cf2691..810c3469 100644
--- a/kernel/cbytecodes.ml
+++ b/kernel/cbytecodes.ml
@@ -43,7 +43,7 @@ type structured_constant =
 type reloc_table = (tag * int) array
 
 type annot_switch =
-   {ci : case_info; rtbl : reloc_table; tailcall : bool}
+   {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int}
 
 module Label =
   struct
@@ -87,6 +87,7 @@ type instruction =
   | Ksequence of bytecodes * bytecodes
   | Kproj of int * Constant.t  (* index of the projected argument,
                                            name of projection *)
+  | Kensurestackcapacity of int
 (* spiwack: instructions concerning integers *)
   | Kbranch of Label.t                  (* jump to label *)
   | Kaddint31                           (* adds the int31 in the accu
@@ -142,11 +143,29 @@ type fv = fv_elem array
 exception NotClosed
 
 
+module Fv_elem =
+struct
+type t = fv_elem
+
+let compare e1 e2 = match e1, e2 with
+| FVnamed id1, FVnamed id2 -> Id.compare id1 id2
+| FVnamed _, _ -> -1
+| FVrel _, FVnamed _ -> 1
+| FVrel r1, FVrel r2 -> Int.compare r1 r2
+| FVrel _, FVuniv_var _ -> -1
+| FVuniv_var i1, FVuniv_var i2 -> Int.compare i1 i2
+| FVuniv_var i1, _ -> 1
+
+end
+
+module FvMap = Map.Make(Fv_elem)
+
 (*spiwack: both type have been moved from Cbytegen because I needed then
   for the retroknowledge *)
 type vm_env = {
     size : int;              (* longueur de la liste [n] *)
-    fv_rev : fv_elem list    (* [fvn; ... ;fv1] *)
+    fv_rev : fv_elem list;   (* [fvn; ... ;fv1] *)
+    fv_fwd : int FvMap.t;    (* reverse mapping *)
   }
 
 
@@ -184,9 +203,6 @@ let rec pp_struct_const = function
 
 let pp_lbl lbl = str "L" ++ int lbl
 
-let pp_pcon (id,u) =
-  pr_con id ++ str "@{" ++ Univ.Instance.pr Univ.Level.pr u ++ str "}"
-
 let pp_fv_elem = function
   | FVnamed id -> str "FVnamed(" ++ Id.print id ++ str ")"
   | FVrel i -> str "Rel(" ++ int i ++ str ")"
@@ -249,6 +265,8 @@ let rec pp_instr i =
 
   | Kproj(n,p) -> str "proj " ++ int n ++ str " " ++ Constant.print p
 
+  | Kensurestackcapacity size -> str "growstack " ++ int size
+
   | Kaddint31 -> str "addint31"
   | Kaddcint31 -> str "addcint31"
   | Kaddcarrycint31 -> str "addcarrycint31"
diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli
index 6fa0841a..b8de7619 100644
--- a/kernel/cbytecodes.mli
+++ b/kernel/cbytecodes.mli
@@ -39,7 +39,7 @@ val pp_struct_const : structured_constant -> Pp.std_ppcmds
 type reloc_table = (tag * int) array
 
 type annot_switch =
-   {ci : case_info; rtbl : reloc_table; tailcall : bool}
+   {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int}
 
 module Label :
   sig
@@ -84,6 +84,7 @@ type instruction =
   | Ksequence of bytecodes * bytecodes
   | Kproj of int * Constant.t  (** index of the projected argument,
                                             name of projection *)
+  | Kensurestackcapacity of int
 
 (** spiwack: instructions concerning integers *)
   | Kbranch of Label.t                  (** jump to label, is it needed ? *)
@@ -139,11 +140,14 @@ type fv = fv_elem array
             closed terms. *)
 exception NotClosed
 
+module FvMap : Map.S with type key = fv_elem
+
 (*spiwack: both type have been moved from Cbytegen because I needed them
   for the retroknowledge *)
 type vm_env = {
     size : int;              (** length of the list [n] *)
-    fv_rev : fv_elem list    (** [fvn; ... ;fv1] *)
+    fv_rev : fv_elem list;   (** [fvn; ... ;fv1] *)
+    fv_fwd : int FvMap.t;    (** reverse mapping *)
   }
 
 
diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml
index 77eac9ee..b1fc0c85 100644
--- a/kernel/cbytegen.ml
+++ b/kernel/cbytegen.ml
@@ -91,9 +91,19 @@ open Pre_env
 (* In Cfxe_t accumulators, we need to store [fcofixi] for testing         *)
 (* conversion of cofixpoints (which is intentional).                      *)
 
+module Config = struct
+  let stack_threshold = 256 (* see byterun/coq_memory.h *)
+  let stack_safety_margin = 15
+end
+
 type argument = ArgConstr of Constr.t | ArgUniv of Univ.Level.t
 
-let empty_fv = { size= 0;  fv_rev = [] }
+let empty_fv = { size= 0;  fv_rev = []; fv_fwd = FvMap.empty }
+let push_fv d e = {
+  size = e.size + 1;
+  fv_rev = d :: e.fv_rev;
+  fv_fwd = FvMap.add d e.size e.fv_fwd;
+}
 
 let fv r = !(r.in_env)
 
@@ -107,6 +117,26 @@ let empty_comp_env ?(univs=0) ()=
     in_env = ref empty_fv
   }
 
+(* Maximal stack size reached during the current function body. Used to
+   reallocate the stack if we lack space. *)
+let max_stack_size = ref 0
+
+let set_max_stack_size stack_size =
+  if stack_size > !max_stack_size then
+    max_stack_size := stack_size
+
+let ensure_stack_capacity f x =
+  let old = !max_stack_size in
+  max_stack_size := 0;
+  let code = f x in
+  let used_safe =
+    !max_stack_size + Config.stack_safety_margin
+  in
+  max_stack_size := old;
+  if used_safe > Config.stack_threshold then
+    Kensurestackcapacity used_safe :: code
+  else code
+
 (*i Creation functions for comp_env *)
 
 let rec add_param n sz l =
@@ -184,20 +214,15 @@ let push_local sz r =
     in_stack = (sz + 1) :: r.in_stack }
 
 (*i Compilation of variables *)
-let find_at f l =
-  let rec aux n = function
-    | [] -> raise Not_found
-    | hd :: tl -> if f hd then n else aux (n + 1) tl
-  in aux 1 l
+let find_at fv env = FvMap.find fv env.fv_fwd
 
 let pos_named id r =
   let env = !(r.in_env) in
   let cid = FVnamed id in
-  let f = function FVnamed id' -> Id.equal id id' | _ -> false in
-  try Kenvacc(r.offset + env.size - (find_at f env.fv_rev))
+  try Kenvacc(r.offset + find_at cid env)
   with Not_found ->
     let pos = env.size in
-    r.in_env := { size = pos+1; fv_rev =  cid:: env.fv_rev};
+    r.in_env := push_fv cid env;
     Kenvacc (r.offset + pos)
 
 let pos_rel i r sz =
@@ -212,11 +237,10 @@ let pos_rel i r sz =
       let i = i - r.nb_rec in
       let db = FVrel(i) in
       let env = !(r.in_env) in
-      let f = function FVrel j -> Int.equal i j | _ -> false in
-      try Kenvacc(r.offset + env.size - (find_at f env.fv_rev))
+      try Kenvacc(r.offset + find_at db env)
       with Not_found ->
 	let pos = env.size in
-	r.in_env := { size = pos+1; fv_rev =  db:: env.fv_rev};
+	r.in_env := push_fv db env;
 	Kenvacc(r.offset + pos)
 
 let pos_universe_var i r sz =
@@ -224,15 +248,11 @@ let pos_universe_var i r sz =
     Kacc (sz - r.nb_stack - (r.nb_uni_stack - i))
   else
     let env = !(r.in_env) in
-    let f = function
-      | FVuniv_var u -> Int.equal i u
-      | _ -> false
-    in
-    try Kenvacc (r.offset + env.size - (find_at f env.fv_rev))
+    let db = FVuniv_var i in
+    try Kenvacc (r.offset + find_at db env)
     with Not_found ->
       let pos = env.size in
-      let db = FVuniv_var i in
-      r.in_env := { size = pos + 1; fv_rev = db::env.fv_rev } ;
+      r.in_env := push_fv db env;
       Kenvacc(r.offset + pos)
 
 (*i  Examination of the continuation *)
@@ -375,14 +395,28 @@ let const_bn tag args =
   else
     Const_bn(last_variant_tag, Array.append [|Const_b0 (tag - last_variant_tag) |] args)
 
-  
-let code_makeblock arity tag cont = 
+(*
+If [tag] hits the OCaml limitation for non constant constructors, we switch to
+another representation for the remaining constructors:
+[last_variant_tag|tag - last_variant_tag|args]
+
+We subtract last_variant_tag for efficiency of match interpretation.
+ *)
+
+let nest_block tag arity cont =
+  Kconst (Const_b0 (tag - last_variant_tag)) ::
+    Kmakeblock(arity+1, last_variant_tag) :: cont
+
+let code_makeblock ~stack_size ~arity ~tag cont = 
   if tag < last_variant_tag then
     Kmakeblock(arity, tag) :: cont
-  else
-    Kpush :: Kconst (Const_b0 (tag - last_variant_tag)) ::
-    Kmakeblock(arity+1, last_variant_tag) :: cont
+  else begin
+    set_max_stack_size (stack_size + 1);
+    Kpush :: nest_block tag arity cont
+  end
 
+(* [code_construct] compiles an abstracted constructor dropping parameters and
+   updates [fun_code] *)
 (* Inv : nparam + arity > 0 *)
 let code_construct tag nparams arity cont =
   let f_cont =
@@ -391,11 +425,11 @@ let code_construct tag nparams arity cont =
 	[Kconst (Const_b0 tag); Kreturn 0]
        else if tag < last_variant_tag then
          [Kacc 0; Kpop 1; Kmakeblock(arity, tag); Kreturn 0]
-       else 
-         [Kconst (Const_b0 (tag - last_variant_tag)); 
-          Kmakeblock(arity+1, last_variant_tag); Kreturn 0])
+       else
+         nest_block tag arity [Kreturn 0])
     in
     let lbl = Label.create() in
+    (* No need to grow the stack here, as the function does not push stuff. *)
     fun_code := [Ksequence (add_grab (nparams+arity) lbl f_cont,!fun_code)];
     Kclosure(lbl,0) :: cont
 
@@ -511,6 +545,7 @@ let comp_args comp_expr reloc args sz cont =
   done;
   !c
 
+(* Precondition: args not empty *)
 let comp_app comp_fun comp_arg reloc f args sz cont =
   let nargs = Array.length args in
   match is_tailcall cont with
@@ -540,11 +575,12 @@ let compile_fv_elem reloc fv sz cont =
 let rec compile_fv reloc l sz cont =
   match l with
   | [] -> cont
-  | [fvn] -> compile_fv_elem reloc fvn sz cont
+  | [fvn] -> set_max_stack_size (sz + 1); compile_fv_elem reloc fvn sz cont
   | fvn :: tl ->
       compile_fv_elem reloc fvn sz
 	(Kpush :: compile_fv reloc tl (sz + 1) cont)
 
+
 (* Compiling constants *)
 
 let rec get_alias env kn =
@@ -559,6 +595,7 @@ let rec get_alias env kn =
 
 (* sz is the size of the local stack *)
 let rec compile_constr reloc c sz cont =
+  set_max_stack_size sz;
   match kind_of_term c with
   | Meta _ -> invalid_arg "Cbytegen.compile_constr : Meta"
   | Evar _ -> invalid_arg "Cbytegen.compile_constr : Evar"
@@ -607,6 +644,7 @@ let rec compile_constr reloc c sz cont =
 	compile_str_cst reloc (Bstrconst (Const_sorts (Type uglob))) sz cont
       else
 	let compile_get_univ reloc idx sz cont =
+          set_max_stack_size sz;
 	  compile_fv_elem reloc (FVuniv_var idx) sz cont
 	in
         comp_app compile_str_cst compile_get_univ reloc
@@ -626,7 +664,8 @@ let rec compile_constr reloc c sz cont =
       let r_fun = comp_env_fun arity in
       let lbl_fun = Label.create() in
       let cont_fun =
-	compile_constr r_fun body arity [Kreturn arity] in
+        ensure_stack_capacity (compile_constr r_fun body arity) [Kreturn arity]
+      in
       fun_code := [Ksequence(add_grab arity lbl_fun cont_fun,!fun_code)];
       let fv = fv r_fun in
       compile_fv reloc fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont)
@@ -646,9 +685,10 @@ let rec compile_constr reloc c sz cont =
       (* Compilation des types *)
       let env_type = comp_env_fix_type rfv in
       for i = 0 to ndef - 1 do
-	let lbl,fcode =
-	  label_code
-	    (compile_constr env_type type_bodies.(i) 0 [Kstop]) in
+        let fcode =
+          ensure_stack_capacity (compile_constr env_type type_bodies.(i) 0) [Kstop]
+        in
+	let lbl,fcode = label_code fcode in
 	lbl_types.(i) <- lbl;
 	fun_code := [Ksequence(fcode,!fun_code)]
       done;
@@ -658,7 +698,8 @@ let rec compile_constr reloc c sz cont =
 	let arity = List.length params in
 	let env_body = comp_env_fix ndef i arity rfv in
 	let cont1 =
-	  compile_constr env_body body arity [Kreturn arity] in
+	  ensure_stack_capacity (compile_constr env_body body arity) [Kreturn arity]
+        in
 	let lbl = Label.create () in
 	lbl_bodies.(i) <- lbl;
 	let fcode =  add_grabrec rec_args.(i) arity lbl cont1 in
@@ -676,9 +717,10 @@ let rec compile_constr reloc c sz cont =
       let rfv = ref empty_fv in
       let env_type = comp_env_cofix_type ndef rfv in
       for i = 0 to ndef - 1 do
-	let lbl,fcode =
-	  label_code
-	    (compile_constr env_type type_bodies.(i) 0 [Kstop]) in
+        let fcode =
+          ensure_stack_capacity (compile_constr env_type type_bodies.(i) 0) [Kstop]
+        in
+	let lbl,fcode = label_code fcode in
 	lbl_types.(i) <- lbl;
 	fun_code := [Ksequence(fcode,!fun_code)]
       done;
@@ -688,14 +730,17 @@ let rec compile_constr reloc c sz cont =
 	let arity = List.length params in
 	let env_body = comp_env_cofix ndef arity rfv in
 	let lbl = Label.create () in
-	let cont1 =
-	  compile_constr env_body body (arity+1) (cont_cofix arity) in
-	let cont2 =
-	  add_grab (arity+1) lbl cont1 in
+        let comp arity =
+          (* 4 stack slots are needed to update the cofix when forced *)
+          set_max_stack_size (arity + 4);
+          compile_constr env_body body (arity+1) (cont_cofix arity)
+        in
+	let cont = ensure_stack_capacity comp arity in
 	lbl_bodies.(i) <- lbl;
-	fun_code := [Ksequence(cont2,!fun_code)];
+	fun_code := [Ksequence(add_grab (arity+1) lbl cont,!fun_code)];
       done;
       let fv = !rfv in
+      set_max_stack_size (sz + fv.size + ndef + 2);
       compile_fv reloc fv.fv_rev sz
 	(Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont)
 
@@ -713,9 +758,11 @@ let rec compile_constr reloc c sz cont =
       let lbl_eblocks = Array.make neblock Label.no in 
       let branch1,cont = make_branch cont in
       (* Compiling return type *)
-      let lbl_typ,fcode =
-	label_code (compile_constr reloc t sz [Kpop sz; Kstop])
-      in fun_code := [Ksequence(fcode,!fun_code)];
+      let fcode =
+        ensure_stack_capacity (compile_constr reloc t sz) [Kpop sz; Kstop]
+      in
+      let lbl_typ,fcode = label_code fcode in
+      fun_code := [Ksequence(fcode,!fun_code)];
       (* Compiling branches *)
       let lbl_sw = Label.create () in
       let sz_b,branch,is_tailcall =
@@ -725,14 +772,9 @@ let rec compile_constr reloc c sz cont =
 	  sz, branch1, true
 	| _ -> sz+3, Kjump, false
       in
-      let annot = {ci = ci; rtbl = tbl; tailcall = is_tailcall} in
-     (* Compiling branch for accumulators *)
-      let lbl_accu, code_accu =
-	label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch::cont)
-      in
-      lbl_blocks.(0) <- lbl_accu;
-      let c = ref code_accu in
-      (* perform the extra match if needed (to many block constructors) *)
+
+      let c = ref cont in
+      (* Perform the extra match if needed (too many block constructors) *)
       if neblock <> 0 then begin
         let lbl_b, code_b = 
           label_code (
@@ -762,14 +804,34 @@ let rec compile_constr reloc c sz cont =
 	      compile_constr reloc branchs.(i) (sz_b+arity)
 		(Kappterm(arity,sz_appterm) :: !c) in
           let code_b = 
-            if tag < last_variant_tag then Kpushfields arity :: code_b
-            else Kacc 0::Kpop 1::Kpushfields(arity+1)::Kpop 1::code_b in
+            if tag < last_variant_tag then begin
+                set_max_stack_size (sz_b + arity);
+                Kpushfields arity :: code_b
+              end
+            else begin
+                set_max_stack_size (sz_b + arity + 1);
+                Kacc 0::Kpop 1::Kpushfields(arity+1)::Kpop 1::code_b
+              end
+          in
           let lbl_b,code_b = label_code code_b in
           if tag < last_variant_tag then lbl_blocks.(tag) <- lbl_b
           else lbl_eblocks.(tag - last_variant_tag) <- lbl_b;
 	  c := code_b
       done;
-      c := Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: !c;
+
+      let annot =
+        {ci = ci; rtbl = tbl; tailcall = is_tailcall;
+         max_stack_size = !max_stack_size - sz}
+      in
+
+     (* Compiling branch for accumulators *)
+      let lbl_accu, code_accu =
+        set_max_stack_size (sz+3);
+	label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch :: !c)
+      in
+      lbl_blocks.(0) <- lbl_accu;
+
+      c := Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: code_accu;
       let code_sw =
  	match branch1 with
         (* spiwack : branch1 can't be a lbl anymore it's a Branch instead
@@ -786,12 +848,14 @@ let rec compile_constr reloc c sz cont =
 	code_sw)
 
 and compile_str_cst reloc sc sz cont =
+  set_max_stack_size sz;
   match sc with
   | Bconstr c -> compile_constr reloc c sz cont
   | Bstrconst sc -> Kconst sc :: cont
   | Bmakeblock(tag,args) ->
-      let nargs = Array.length args in
-      comp_args compile_str_cst reloc args sz (code_makeblock nargs tag cont)
+      let arity = Array.length args in
+      let cont = code_makeblock ~stack_size:(sz+arity-1) ~arity ~tag cont in
+      comp_args compile_str_cst reloc args sz cont
   | Bconstruct_app(tag,nparams,arity,args) ->
       if Int.equal (Array.length args) 0 then
         code_construct tag nparams arity cont
@@ -805,6 +869,7 @@ 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_get_global reloc (kn,u) sz cont =
+  set_max_stack_size sz;
   let kn = get_alias !global_env kn in
   if Univ.Instance.is_empty u then
     Kgetglobal kn :: cont
@@ -813,11 +878,13 @@ and compile_get_global reloc (kn,u) sz cont =
       compile_universe reloc () (Univ.Instance.to_array u) sz cont
 
 and compile_universe reloc uni sz cont =
+  set_max_stack_size sz;
   match Univ.Level.var_index uni with
   | None -> Kconst (Const_univ_level uni) :: cont
   | Some idx -> pos_universe_var idx reloc sz :: cont
 
 and compile_const reloc kn u args sz cont =
+  set_max_stack_size sz;
   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
@@ -879,7 +946,7 @@ let compile fail_on_error ?universes:(universes=0) env c =
     let reloc, init_code =
       if Int.equal universes 0 then
         let reloc = empty_comp_env () in
-        reloc, compile_constr reloc c 0 cont
+        reloc, ensure_stack_capacity (compile_constr reloc c 0) cont
       else
         (* We are going to generate a lambda, but merge the universe closure
          * with the function closure if it exists.
@@ -896,18 +963,24 @@ let compile fail_on_error ?universes:(universes=0) env c =
         let r_fun = comp_env_fun ~univs:universes arity in
         let lbl_fun = Label.create () in
         let cont_fun =
-          compile_constr r_fun body full_arity [Kreturn full_arity]
+          ensure_stack_capacity (compile_constr r_fun body full_arity)
+                         [Kreturn full_arity]
         in
         fun_code := [Ksequence(add_grab full_arity lbl_fun cont_fun,!fun_code)];
         let fv = fv r_fun in
-        reloc, compile_fv reloc fv.fv_rev 0 (Kclosure(lbl_fun,fv.size) :: cont)
+        let init_code =
+          ensure_stack_capacity (compile_fv reloc fv.fv_rev 0)
+                         (Kclosure(lbl_fun,fv.size) :: cont)
+        in
+        reloc, init_code
     in
     let fv = List.rev (!(reloc.in_env).fv_rev) in
     (if !Flags.dump_bytecode then
-      Pp.msg_debug (dump_bytecodes init_code !fun_code fv)) ;
+      Feedback.msg_debug (dump_bytecodes init_code !fun_code fv)) ;
     Some (init_code,!fun_code, Array.of_list fv)
   with TooLargeInductive tname ->
-    let fn = if fail_on_error then Errors.errorlabstrm "compile" else Pp.msg_warning in
+    let fn = if fail_on_error then CErrors.errorlabstrm "compile" else
+	       (fun x -> Feedback.msg_warning x) in
       (Pp.(fn
 	   (str "Cannot compile code for virtual machine as it uses inductive " ++
 	    Id.print tname ++ str str_max_constructors));
diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml
index 57e32684..ad7a41a3 100644
--- a/kernel/cemitcodes.ml
+++ b/kernel/cemitcodes.ml
@@ -29,11 +29,19 @@ let patch_char4 buff pos c1 c2 c3 c4 =
   String.unsafe_set buff (pos + 2) c3;
   String.unsafe_set buff (pos + 3) c4 
   
-let patch_int buff pos n =
+let patch buff (pos, n) =
   patch_char4 buff pos 
     (Char.unsafe_chr n) (Char.unsafe_chr (n asr 8))  (Char.unsafe_chr (n asr 16))
     (Char.unsafe_chr (n asr 24))
 
+let patch_int buff patches =
+  (* copy code *before* patching because of nested evaluations:
+     the code we are patching might be called (and thus "concurrently" patched)
+     and results in wrong results. Side-effects... *)
+  let buff = String.copy buff in
+  let () = List.iter (fun p -> patch buff p) patches in
+  buff
+
 (* Buffering of bytecode *)
 
 let out_buffer = ref(String.create 1024)
@@ -226,6 +234,7 @@ let emit_instr = function
       else (out opSETFIELD;out_int n)
   | Ksequence _ -> invalid_arg "Cemitcodes.emit_instr"
   | Kproj (n,p) -> out opPROJ; out_int n; slot_for_const (Const_proj p)
+  | Kensurestackcapacity size -> out opENSURESTACKCAPACITY; out_int size
   (* spiwack *)
   | Kbranch lbl -> out opBRANCH; out_label lbl
   | Kaddint31 -> out opADDINT31
@@ -298,8 +307,6 @@ let init () =
 
 type emitcodes = string
 
-let copy = String.copy
-
 let length = String.length
 
 type to_patch = emitcodes * (patch list) * fv
@@ -324,8 +331,6 @@ let subst_patch s (ri,pos) =
 let subst_to_patch s (code,pl,fv) =
   code,List.rev_map (subst_patch s) pl,fv
 
-let subst_pconstant s (kn, u) = (fst (subst_con_kn s kn), u)
-
 type body_code =
   | BCdefined of to_patch
   | BCalias of Names.constant
@@ -366,6 +371,8 @@ let to_memory (init_code, fun_code, fv) =
   emit fun_code;
   let code = String.create !out_position in
   String.unsafe_blit !out_buffer 0 code 0 !out_position;
+  (** Later uses of this string are all purely functional *)
+  let code = CString.hcons code in
   let reloc = List.rev !reloc_info in
   Array.iter (fun lbl ->
     (match lbl with
diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli
index 10f3a608..c80edd59 100644
--- a/kernel/cemitcodes.mli
+++ b/kernel/cemitcodes.mli
@@ -13,11 +13,9 @@ val subst_patch : Mod_subst.substitution -> patch -> patch
 
 type emitcodes
 
-val copy : emitcodes -> emitcodes
-
 val length : emitcodes -> int
 
-val patch_int : emitcodes -> (*pos*)int -> int -> unit
+val patch_int : emitcodes -> ((*pos*)int * int) list -> emitcodes
 
 type to_patch = emitcodes * (patch list) * fv
 
diff --git a/kernel/constr.ml b/kernel/constr.ml
index 7e103b1d..ce20751a 100644
--- a/kernel/constr.ml
+++ b/kernel/constr.ml
@@ -41,12 +41,24 @@ 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 }
+
+(* INVARIANT:
+ * - Array.length ci_cstr_ndecls = Array.length ci_cstr_nargs
+ * - forall (i : 0 .. pred (Array.length ci_cstr_ndecls)),
+ *          ci_cstr_ndecls.(i) >= ci_cstr_nargs.(i)
+ *)
 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 *)
+  { ci_ind        : inductive;      (* inductive type to which belongs the value that is being matched *)
+    ci_npar       : int;            (* number of parameters of the above inductive type *)
+    ci_cstr_ndecls : int array;     (* For each constructor, the corresponding integer determines
+                                       the number of values that can be bound in a match-construct.
+                                       NOTE: parameters of the inductive type are therefore excluded from the count *)
+    ci_cstr_nargs : int array;      (* for each constructor, the corresponding integers determines
+                                       the number of values that can be applied to the constructor,
+                                       in addition to the parameters of the related inductive type
+                                       NOTE: "lets" are therefore excluded from the count
+                                       NOTE: parameters of the inductive type are also excluded from the count *)
+    ci_pp_info    : case_printing   (* not interpreted by the kernel *)
   }
 
 (********************************************************************)
@@ -545,8 +557,8 @@ 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 eq_universes _ = UGraph.check_eq_instances univs in
+    let eq_sorts s1 s2 = s1 == s2 || UGraph.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
@@ -554,11 +566,11 @@ let eq_constr_univs univs 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_universes _ = UGraph.check_eq_instances univs in
     let eq_sorts s1 s2 = s1 == s2 || 
-      Univ.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in
+      UGraph.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
+      UGraph.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
@@ -571,12 +583,12 @@ 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_universes strict = UGraph.check_eq_instances 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
+	if UGraph.check_eq univs u1 u2 then true
 	else
 	  (cstrs := Univ.enforce_eq u1 u2 !cstrs;
 	   true)
@@ -591,12 +603,12 @@ 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_universes strict l l' = UGraph.check_eq_instances 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
+	if UGraph.check_eq univs u1 u2 then true
 	else (cstrs := Univ.enforce_eq u1 u2 !cstrs;
 	      true)
     in
@@ -604,7 +616,7 @@ let leq_constr_univs_infer univs m n =
       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
+	if UGraph.check_leq univs u1 u2 then true
 	else
 	  (cstrs := Univ.enforce_leq u1 u2 !cstrs; 
 	   true)
@@ -732,12 +744,10 @@ let hasheq t1 t2 =
       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
+    | Evar (e1,l1), Evar (e2,l2) -> 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
+    | Ind (ind1,u1), Ind (ind2,u2) -> ind1 == ind2 && u1 == u2
+    | Construct (cstr1,u1), Construct (cstr2,u2) -> cstr1 == cstr2 && 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)) ->
@@ -757,10 +767,10 @@ let hasheq t1 t2 =
     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)
+  Hashset.Make(struct type t = constr let eq = hasheq end)
 
 module HashsetTermArray =
-  Hashset.Make(struct type t = constr array let equal = array_eqeq end)
+  Hashset.Make(struct type t = constr array let eq = array_eqeq end)
 
 let term_table = HashsetTerm.create 19991
 (* The associative table to hashcons terms. *)
@@ -815,19 +825,19 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) =
       | 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))
+	  (Proj (p', c), combinesmall 17 (combine (Projection.SyntacticOrd.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) ->
+	(Const (c', u'), combinesmall 9 (combine (Constant.SyntacticOrd.hash c) hu))
+      | Ind (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))->
+	 combinesmall 10 (combine (ind_syntactic_hash ind) hu))
+      | Construct (c,u) ->
 	let u', hu = sh_instance u in
 	(Construct (sh_construct c, u'),
-	 combinesmall 11 (combine (constructor_hash c) hu))
+	 combinesmall 11 (combine (constructor_syntactic_hash c) hu))
       | Case (ci,p,c,bl) ->
 	let p, hp = sh_rec p
 	and c, hc = sh_rec c in
@@ -930,7 +940,7 @@ struct
     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' =
+  let eq 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 *)
@@ -972,7 +982,7 @@ module Hsorts =
       let hashcons huniv = function
           Prop c -> Prop c
         | Type u -> Type (huniv u)
-      let equal s1 s2 =
+      let eq s1 s2 =
         s1 == s2 ||
 	  match (s1,s2) with
             (Prop c1, Prop c2) -> c1 == c2
diff --git a/kernel/constr.mli b/kernel/constr.mli
index c3118cdf..42d298e3 100644
--- a/kernel/constr.mli
+++ b/kernel/constr.mli
@@ -6,6 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(** This file defines the most important datatype of Coq, namely kernel terms,
+    as well as a handful of generic manipulation functions. *)
+
 open Names
 
 (** {6 Value under universe substitution } *)
@@ -30,13 +33,23 @@ type case_printing =
     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 *)
+(* INVARIANT:
+ * - Array.length ci_cstr_ndecls = Array.length ci_cstr_nargs
+ * - forall (i : 0 .. pred (Array.length ci_cstr_ndecls)),
+ *          ci_cstr_ndecls.(i) >= ci_cstr_nargs.(i)
+ *)
 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 *)
+  { ci_ind        : inductive;      (* inductive type to which belongs the value that is being matched *)
+    ci_npar       : int;            (* number of parameters of the above inductive type *)
+    ci_cstr_ndecls : int array;     (* For each constructor, the corresponding integer determines
+                                       the number of values that can be bound in a match-construct.
+                                       NOTE: parameters of the inductive type are therefore excluded from the count *)
+    ci_cstr_nargs : int array;      (* for each constructor, the corresponding integers determines
+                                       the number of values that can be applied to the constructor,
+                                       in addition to the parameters of the related inductive type
+                                       NOTE: "lets" are therefore excluded from the count
+                                       NOTE: parameters of the inductive type are also excluded from the count *)
+    ci_pp_info    : case_printing   (* not interpreted by the kernel *)
   }
 
 (** {6 The type of constructions } *)
@@ -93,8 +106,9 @@ 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)$ %}. *)
+(** [mkApp (f, [|t1; ...; tN|]] constructs the application
+    {%html:(f t<sub>1</sub> ... t<sub>n</sub>)%}
+    {%latex:$(f~t_1\dots f_n)$%}. *)
 val mkApp : constr * constr array -> constr
 
 val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses
@@ -181,10 +195,13 @@ type ('constr, 'types) kind_of_term =
   | 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
+  | Prod      of Name.t * 'types * 'types             (** Concrete syntax ["forall A:B,C"] is represented as [Prod (A,B,C)]. *)
+  | Lambda    of Name.t * 'types * 'constr            (** Concrete syntax ["fun A:B => C"] is represented as [Lambda (A,B,C)].  *)
+  | LetIn     of Name.t * 'constr * 'types * 'constr  (** Concrete syntax ["let A:B := C in D"] is represented as [LetIn (A,B,C,D)]. *)
+  | App       of 'constr * 'constr array              (** Concrete syntax ["(F P1 P2 ...  Pn)"] is represented as [App (F, [|P1; P2; ...; Pn|])].
+                                                          The {!mkApp} constructor also enforces the following invariant:
+                                                          - [F] itself is not {!App}
+                                                          - and [[|P1;..;Pn|]] is not empty. *)
   | Const     of constant puniverses
   | Ind       of inductive puniverses
   | Construct of constructor puniverses
@@ -205,19 +222,19 @@ 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
+val eq_constr_univs : constr UGraph.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
+val leq_constr_univs : constr UGraph.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
+val eq_constr_univs_infer : UGraph.t -> 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
+val leq_constr_univs_infer : UGraph.t -> 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. *)
diff --git a/kernel/context.ml b/kernel/context.ml
index 454d4f25..4e53b73a 100644
--- a/kernel/context.ml
+++ b/kernel/context.ml
@@ -15,123 +15,409 @@
 (* 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
+(** The modules defined below represent a {e local context}
+    as defined by Chapter 4 in the Reference Manual:
 
-let rec lookup_rel n sign =
-  match n, sign with
-  | 1, decl :: _ -> decl
-  | n, _ :: sign -> lookup_rel (n-1) sign
-  | _, []        -> raise Not_found
+    A {e local context} is an ordered list of of {e local declarations}
+    of names that we call {e variables}.
 
-let rel_context_length = List.length
+    A {e local declaration} of some variable can be either:
+    - a {e local assumption}, or
+    - a {e local definition}.
+*)
 
-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
+open Util
+open Names
 
-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)
+(** Representation of contexts that can capture anonymous as well as non-anonymous variables.
+    Individual declarations are then designated by de Bruijn indexes. *)
+module Rel =
+struct
+  (** Representation of {e local declarations}. *)
+  module Declaration =
+  struct
+    (* local declaration *)
+    type t =
+      | LocalAssum of Name.t * Constr.t            (** name, type *)
+      | LocalDef of Name.t * Constr.t * Constr.t   (** name, value, type *)
+
+    (** Return the name bound by a given declaration. *)
+    let get_name = function
+      | LocalAssum (na,_)
+      | LocalDef (na,_,_) -> na
+
+    (** Return [Some value] for local-declarations and [None] for local-assumptions. *)
+    let get_value = function
+      | LocalAssum _ -> None
+      | LocalDef (_,v,_) -> Some v
+                                 
+    (** Return the type of the name bound by a given declaration. *)
+    let get_type = function
+      | LocalAssum (_,ty)
+      | LocalDef (_,_,ty) -> ty
+                               
+    (** Set the name that is bound by a given declaration. *)
+    let set_name na = function
+      | LocalAssum (_,ty) -> LocalAssum (na, ty)
+      | LocalDef (_,v,ty) -> LocalDef (na, v, ty)
+
+    (** Set the type of the bound variable in a given declaration. *)
+    let set_type ty = function
+      | LocalAssum (na,_) -> LocalAssum (na, ty)
+      | LocalDef (na,v,_) -> LocalDef (na, v, ty)
+
+    (** Return [true] iff a given declaration is a local assumption. *)
+    let is_local_assum = function
+      | LocalAssum _ -> true
+      | LocalDef _ -> false
+
+    (** Return [true] iff a given declaration is a local definition. *)
+    let is_local_def = function
+      | LocalAssum _ -> false
+      | LocalDef _ -> true
+
+    (** Check whether any term in a given declaration satisfies a given predicate. *)
+    let exists f = function
+      | LocalAssum (_, ty) -> f ty
+      | LocalDef (_, v, ty) -> f v || f ty
+
+      (** Check whether all terms in a given declaration satisfy a given predicate. *)
+    let for_all f = function
+      | LocalAssum (_, ty) -> f ty
+      | LocalDef (_, v, ty) -> f v && f ty
+
+    (** Check whether the two given declarations are equal. *)
+    let equal decl1 decl2 =
+      match decl1, decl2 with
+      | LocalAssum (n1,ty1), LocalAssum (n2, ty2) ->
+          Name.equal n1 n2 && Constr.equal ty1 ty2
+      | LocalDef (n1,v1,ty1), LocalDef (n2,v2,ty2) ->
+          Name.equal n1 n2 && Constr.equal v1 v2 && Constr.equal ty1 ty2
+      | _ ->
+          false
+
+    (** Map the name bound by a given declaration. *)
+    let map_name f = function
+      | LocalAssum (na, ty) as decl ->
+          let na' = f na in
+          if na == na' then decl else LocalAssum (na', ty)
+      | LocalDef (na, v, ty) as decl ->
+          let na' = f na in
+          if na == na' then decl else LocalDef (na', v, ty)
+
+    (** For local assumptions, this function returns the original local assumptions.
+        For local definitions, this function maps the value in the local definition. *)
+    let map_value f = function
+      | LocalAssum _ as decl -> decl
+      | LocalDef (na, v, t) as decl ->
+          let v' = f v in
+          if v == v' then decl else LocalDef (na, v', t)
+
+    (** Map the type of the name bound by a given declaration. *)
+    let map_type f = function
+      | LocalAssum (na, ty) as decl ->
+          let ty' = f ty in
+          if ty == ty' then decl else LocalAssum (na, ty')
+      | LocalDef (na, v, ty) as decl ->         
+          let ty' = f ty in
+          if ty == ty' then decl else LocalDef (na, v, ty')
+
+    (** Map all terms in a given declaration. *)
+    let map_constr f = function
+      | LocalAssum (na, ty) as decl ->
+          let ty' = f ty in
+          if ty == ty' then decl else LocalAssum (na, ty')
+      | LocalDef (na, v, ty) as decl ->
+          let v' = f v in
+          let ty' = f ty in
+          if v == v' && ty == ty' then decl else LocalDef (na, v', ty')
+
+    (** Perform a given action on all terms in a given declaration. *)
+    let iter_constr f = function
+      | LocalAssum (_,ty) -> f ty
+      | LocalDef (_,v,ty) -> f v; f ty
+
+    (** Reduce all terms in a given declaration to a single value. *)
+    let fold f decl acc =
+      match decl with
+      | LocalAssum (n,ty) -> f ty acc
+      | LocalDef (n,v,ty) -> f ty (f v acc)
+
+    let to_tuple = function
+      | LocalAssum (na, ty) -> na, None, ty
+      | LocalDef (na, v, ty) -> na, Some v, ty
+
+    let of_tuple = function
+      | n, None, ty -> LocalAssum (n,ty)
+      | n, Some v, ty -> LocalDef (n,v,ty)
+  end
+
+  (** Rel-context is represented as a list of declarations.
+      Inner-most declarations are at the beginning of the list.
+      Outer-most declarations are at the end of the list. *)
+  type t = Declaration.t list
+
+  (** empty rel-context *)
+  let empty = []
+
+  (** Return a new rel-context enriched by with a given inner-most declaration. *)
+  let add d ctx = d :: ctx
+
+  (** Return the number of {e local declarations} in a given context. *)
+  let length = List.length
+
+  (** [extended_rel_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ]
+      with n = |Δ| and with the local definitions of [Γ] skipped in
+      [args]. Example: for [x:T,y:=c,z:U] and [n]=2, it gives [Rel 5, Rel 3]. *)
+  let nhyps =
+    let open Declaration in
+    let rec nhyps acc = function
+      | [] -> acc
+      | LocalAssum _ :: hyps -> nhyps (succ acc) hyps
+      | LocalDef _ :: hyps -> nhyps acc hyps
+    in
+    nhyps 0
+
+  (** Return a declaration designated by a given de Bruijn index.
+      @raise Not_found if the designated de Bruijn index is not present in the designated rel-context. *)
+  let rec lookup n ctx =
+    match n, ctx with
+    | 1, decl :: _ -> decl
+    | n, _ :: sign -> lookup (n-1) sign
+    | _, []        -> raise Not_found
+
+  (** Check whether given two rel-contexts are equal. *)
+  let equal = List.equal Declaration.equal
+
+  (** Map all terms in a given rel-context. *)
+  let map f = List.smartmap (Declaration.map_constr f)
+
+  (** Perform a given action on every declaration in a given rel-context. *)
+  let iter f = List.iter (Declaration.iter_constr f)
+
+  (** Reduce all terms in a given rel-context to a single value.
+      Innermost declarations are processed first. *)
+  let fold_inside f ~init = List.fold_left f init
+
+  (** Reduce all terms in a given rel-context to a single value.
+      Outermost declarations are processed first. *)
+  let fold_outside f l ~init = List.fold_right f l init
+
+  (** Map a given rel-context to a list where each {e local assumption} is mapped to [true]
+      and each {e local definition} is mapped to [false]. *)
+  let to_tags =
+    let rec aux l = function
+      | [] -> l
+      | Declaration.LocalDef _ :: ctx -> aux (true::l) ctx
+      | Declaration.LocalAssum _ :: ctx -> aux (false::l) ctx
+    in aux []
+
+  (** [extended_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ]
+      with n = |Δ| and with the {e local definitions} of [Γ] skipped in
+      [args]. Example: for [x:T, y:=c, z:U] and [n]=2, it gives [Rel 5, Rel 3]. *)
+  let to_extended_list n =
+    let rec reln l p = function
+      | Declaration.LocalAssum _ :: hyps -> reln (Constr.mkRel (n+p) :: l) (p+1) hyps
+      | Declaration.LocalDef _ :: hyps -> reln l (p+1) hyps
+      | [] -> l
+    in
+    reln [] 1
+
+  (** [extended_vect n Γ] does the same, returning instead an array. *)
+  let to_extended_vect n hyps = Array.of_list (to_extended_list n hyps)
+end
+
+(** This module represents contexts that can capture non-anonymous variables.
+    Individual declarations are then designated by the identifiers they bind. *)
+module Named =
+struct
+  (** Representation of {e local declarations}. *)
+  module Declaration =
+  struct
+    (** local declaration *)
+    type t =
+      | LocalAssum of Id.t * Constr.t             (** identifier, type *)
+      | LocalDef of Id.t * Constr.t * Constr.t    (** identifier, value, type *)
+
+    (** Return the identifier bound by a given declaration. *)
+    let get_id = function
+      | LocalAssum (id,_) -> id
+      | LocalDef (id,_,_) -> id
+
+    (** Return [Some value] for local-declarations and [None] for local-assumptions. *)
+    let get_value = function
+      | LocalAssum _ -> None
+      | LocalDef (_,v,_) -> Some v
+
+    (** Return the type of the name bound by a given declaration. *)
+    let get_type = function
+      | LocalAssum (_,ty)
+      | LocalDef (_,_,ty) -> ty
+
+    (** Set the identifier that is bound by a given declaration. *)
+    let set_id id = function
+      | LocalAssum (_,ty) -> LocalAssum (id, ty)
+      | LocalDef (_, v, ty) -> LocalDef (id, v, ty)
+
+    (** Set the type of the bound variable in a given declaration. *)
+    let set_type ty = function
+      | LocalAssum (id,_) -> LocalAssum (id, ty)
+      | LocalDef (id,v,_) -> LocalDef (id, v, ty)
+
+    (** Return [true] iff a given declaration is a local assumption. *)
+    let is_local_assum = function
+      | LocalAssum _ -> true
+      | LocalDef _ -> false
+
+    (** Return [true] iff a given declaration is a local definition. *)
+    let is_local_def = function
+      | LocalDef _ -> true
+      | LocalAssum _ -> false
+
+    (** Check whether any term in a given declaration satisfies a given predicate. *)
+    let exists f = function
+      | LocalAssum (_, ty) -> f ty
+      | LocalDef (_, v, ty) -> f v || f ty
+
+    (** Check whether all terms in a given declaration satisfy a given predicate. *)
+    let for_all f = function
+      | LocalAssum (_, ty) -> f ty
+      | LocalDef (_, v, ty) -> f v && f ty
+
+    (** Check whether the two given declarations are equal. *)
+    let equal decl1 decl2 =
+      match decl1, decl2 with
+      | LocalAssum (id1, ty1), LocalAssum (id2, ty2) ->
+          Id.equal id1 id2 && Constr.equal ty1 ty2
+      | LocalDef (id1, v1, ty1), LocalDef (id2, v2, ty2) ->
+          Id.equal id1 id2 && Constr.equal v1 v2 && Constr.equal ty1 ty2
+      | _ ->
+          false
+
+    (** Map the identifier bound by a given declaration. *)
+    let map_id f = function
+      | LocalAssum (id, ty) as decl ->
+          let id' = f id in
+          if id == id' then decl else LocalAssum (id', ty)
+      | LocalDef (id, v, ty) as decl ->
+          let id' = f id in
+          if id == id' then decl else LocalDef (id', v, ty)
+
+    (** For local assumptions, this function returns the original local assumptions.
+        For local definitions, this function maps the value in the local definition. *)
+    let map_value f = function
+      | LocalAssum _ as decl -> decl
+      | LocalDef (na, v, t) as decl ->
+          let v' = f v in
+          if v == v' then decl else LocalDef (na, v', t)
+
+    (** Map the type of the name bound by a given declaration. *)
+    let map_type f = function
+      | LocalAssum (id, ty) as decl ->
+          let ty' = f ty in
+          if ty == ty' then decl else LocalAssum (id, ty')
+      | LocalDef (id, v, ty) as decl ->
+          let ty' = f ty in
+          if ty == ty' then decl else LocalDef (id, v, ty')
+
+    (** Map all terms in a given declaration. *)
+    let map_constr f = function
+      | LocalAssum (id, ty) as decl ->
+          let ty' = f ty in
+          if ty == ty' then decl else LocalAssum (id, ty')
+      | LocalDef (id, v, ty) as decl ->
+          let v' = f v in
+          let ty' = f ty in
+          if v == v' && ty == ty' then decl else LocalDef (id, v', ty')
+
+    (** Perform a given action on all terms in a given declaration. *)
+    let iter_constr f = function
+      | LocalAssum (_, ty) -> f ty
+      | LocalDef (_, v, ty) -> f v; f ty
+
+    (** Reduce all terms in a given declaration to a single value. *)
+    let fold f decl a =
+      match decl with
+      | LocalAssum (_, ty) -> f ty a
+      | LocalDef (_, v, ty) -> a |> f v |> f ty
+
+    let to_tuple = function
+      | LocalAssum (id, ty) -> id, None, ty
+      | LocalDef (id, v, ty) -> id, Some v, ty
+
+    let of_tuple = function
+      | id, None, ty -> LocalAssum (id, ty)
+      | id, Some v, ty -> LocalDef (id, v, ty)
+  end
+
+  (** Named-context is represented as a list of declarations.
+      Inner-most declarations are at the beginning of the list.
+      Outer-most declarations are at the end of the list. *)
+  type t = Declaration.t list
+
+  (** empty named-context *)
+  let empty = []
+
+  (** empty named-context *)
+  let add d ctx = d :: ctx
+
+  (** Return the number of {e local declarations} in a given named-context. *)
+  let length = List.length
+
+(** Return a declaration designated by a given de Bruijn index.
+    @raise Not_found if the designated identifier is not present in the designated named-context. *)   let rec lookup id = function
+    | decl :: _ when Id.equal id (Declaration.get_id decl) -> decl
+    | _ :: sign -> lookup id sign
+    | [] -> raise Not_found
+
+  (** Check whether given two named-contexts are equal. *)
+  let equal = List.equal Declaration.equal
+
+  (** Map all terms in a given named-context. *)
+  let map f = List.smartmap (Declaration.map_constr f)
+
+  (** Perform a given action on every declaration in a given named-context. *)
+  let iter f = List.iter (Declaration.iter_constr f)
+
+  (** Reduce all terms in a given named-context to a single value.
+      Innermost declarations are processed first. *)
+  let fold_inside f ~init = List.fold_left f init
+
+  (** Reduce all terms in a given named-context to a single value.
+      Outermost declarations are processed first. *)
+  let fold_outside f l ~init = List.fold_right f l init
+
+  (** Return the set of all identifiers bound in a given named-context. *)
+  let to_vars =
+    List.fold_left (fun accu decl -> Id.Set.add (Declaration.get_id decl) accu) Id.Set.empty
+
+  (** [instance_from_named_context Ω] builds an instance [args] such
+      that [Ω ⊢ args:Ω] where [Ω] is a named context and with the local
+      definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it
+      gives [Var id1, Var id3]. All [idj] are supposed distinct. *)
+  let to_instance =
+    let filter = function
+      | Declaration.LocalAssum (id, _) -> Some (Constr.mkVar id)
+      | _ -> None
+    in
+    List.map_filter filter
+  end
+
+module NamedList =
+  struct
+    module Declaration =
+      struct
+        type t = Id.t list * Constr.t option * Constr.t
+
+        let map_constr f (ids, copt, ty as decl) =
+          let copt' = Option.map f copt in
+          let ty' = f ty in
+          if copt == copt' && ty == ty' then decl else (ids, copt', ty')
+      end
+
+    type t = Declaration.t list
+
+    let fold f l ~init = List.fold_right f l init
+  end
+
+type section_context = Named.t
diff --git a/kernel/context.mli b/kernel/context.mli
index b78bbb03..b5f3904d 100644
--- a/kernel/context.mli
+++ b/kernel/context.mli
@@ -6,117 +6,255 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(** The modules defined below represent a {e local context}
+    as defined by Chapter 4 in the Reference Manual:
+
+    A {e local context} is an ordered list of of {e local declarations}
+    of names that we call {e variables}.
+
+    A {e local declaration} of some variable can be either:
+    - a {e local assumption}, or
+    - a {e local definition}.
+
+    {e Local assumptions} are denoted in the Reference Manual as [(name : typ)] and
+    {e local definitions} are there denoted as [(name := value : typ)].
+*)
+
 open Names
 
-(** TODO: cleanup *)
+(** Representation of contexts that can capture anonymous as well as non-anonymous variables.
+    Individual declarations are then designated by de Bruijn indexes. *)
+module Rel :
+sig
+  module Declaration :
+  sig
+    (* local declaration *)
+    type t = LocalAssum of Name.t * Constr.t            (** name, type *)
+           | LocalDef of Name.t * Constr.t * Constr.t   (** name, value, type *)
+
+    (** Return the name bound by a given declaration. *)
+    val get_name : t -> Name.t
+
+    (** Return [Some value] for local-declarations and [None] for local-assumptions. *)
+    val get_value : t -> Constr.t option
+
+    (** Return the type of the name bound by a given declaration. *)
+    val get_type : t -> Constr.t
+
+    (** Set the name that is bound by a given declaration. *)
+    val set_name : Name.t -> t -> t
+
+    (** Set the type of the bound variable in a given declaration. *)
+    val set_type : Constr.t -> t -> t
+
+    (** Return [true] iff a given declaration is a local assumption. *)
+    val is_local_assum : t -> bool
+
+    (** Return [true] iff a given declaration is a local definition. *)
+    val is_local_def : t -> bool
+
+    (** Check whether any term in a given declaration satisfies a given predicate. *)
+    val exists : (Constr.t -> bool) -> t -> bool
+
+    (** Check whether all terms in a given declaration satisfy a given predicate. *)
+    val for_all : (Constr.t -> bool) -> t -> bool
+
+    (** Check whether the two given declarations are equal. *)
+    val equal : t -> t -> bool
+
+    (** Map the name bound by a given declaration. *)
+    val map_name : (Name.t -> Name.t) -> t -> t
+
+    (** For local assumptions, this function returns the original local assumptions.
+        For local definitions, this function maps the value in the local definition. *)
+    val map_value : (Constr.t -> Constr.t) -> t -> t
+
+    (** Map the type of the name bound by a given declaration. *)
+    val map_type : (Constr.t -> Constr.t) -> t -> t
+
+    (** Map all terms in a given declaration. *)
+    val map_constr : (Constr.t -> Constr.t) -> t -> t
+
+    (** Perform a given action on all terms in a given declaration. *)
+    val iter_constr : (Constr.t -> unit) -> t -> unit
+
+    (** Reduce all terms in a given declaration to a single value. *)
+    val fold : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a
+
+    val to_tuple : t -> Name.t * Constr.t option * Constr.t
+    val of_tuple : Name.t * Constr.t option * Constr.t -> t
+  end
+
+  (** Rel-context is represented as a list of declarations.
+      Inner-most declarations are at the beginning of the list.
+      Outer-most declarations are at the end of the list. *)
+  type t = Declaration.t list
+
+  (** empty rel-context *)
+  val empty : t
+
+  (** Return a new rel-context enriched by with a given inner-most declaration. *)
+  val add : Declaration.t -> t -> t
+
+  (** Return the number of {e local declarations} in a given context. *)
+  val length : t -> int
+
+  (** Check whether given two rel-contexts are equal. *)
+  val equal : t -> t -> bool
+
+  (** Return the number of {e local assumptions} in a given rel-context. *)
+  val nhyps : t -> int
+
+  (** Return a declaration designated by a given de Bruijn index.
+      @raise Not_found if the designated de Bruijn index outside the range. *)
+  val lookup : int -> t -> Declaration.t
+
+  (** Map all terms in a given rel-context. *)
+  val map : (Constr.t -> Constr.t) -> t -> t
+
+  (** Perform a given action on every declaration in a given rel-context. *)
+  val iter : (Constr.t -> unit) -> t -> unit
+
+  (** Reduce all terms in a given rel-context to a single value.
+      Innermost declarations are processed first. *)
+  val fold_inside : ('a -> Declaration.t -> 'a) -> init:'a -> t -> 'a
+
+  (** Reduce all terms in a given rel-context to a single value.
+      Outermost declarations are processed first. *)
+  val fold_outside : (Declaration.t -> 'a -> 'a) -> t -> init:'a -> 'a
+
+  (** Map a given rel-context to a list where each {e local assumption} is mapped to [true]
+      and each {e local definition} is mapped to [false]. *)
+  val to_tags : t -> bool list
+
+  (** [extended_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ]
+      with n = |Δ| and with the {e local definitions} of [Γ] skipped in
+      [args]. Example: for [x:T, y:=c, z:U] and [n]=2, it gives [Rel 5, Rel 3]. *)
+  val to_extended_list : int -> t -> Constr.t list
+
+  (** [extended_vect n Γ] does the same, returning instead an array. *)
+  val to_extended_vect : int -> t -> Constr.t array
+end
+
+(** This module represents contexts that can capture non-anonymous variables.
+    Individual declarations are then designated by the identifiers they bind. *)
+module Named :
+sig
+  (** Representation of {e local declarations}. *)
+  module Declaration :
+  sig
+    type t = LocalAssum of Id.t * Constr.t            (** identifier, type *)
+           | LocalDef of Id.t * Constr.t * Constr.t   (** identifier, value, type *)
+
+    (** Return the identifier bound by a given declaration. *)
+    val get_id : t -> Id.t
+
+    (** Return [Some value] for local-declarations and [None] for local-assumptions. *)
+    val get_value : t -> Constr.t option
+
+    (** Return the type of the name bound by a given declaration. *)
+    val get_type : t -> Constr.t
+
+    (** Set the identifier that is bound by a given declaration. *)
+    val set_id : Id.t -> t -> t
+
+    (** Set the type of the bound variable in a given declaration. *)
+    val set_type : Constr.t -> t -> t
 
-(** {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) *)
+    (** Return [true] iff a given declaration is a local assumption. *)
+    val is_local_assum : t -> bool
 
-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
+    (** Return [true] iff a given declaration is a local definition. *)
+    val is_local_def : t -> bool
 
-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
+    (** Check whether any term in a given declaration satisfies a given predicate. *)
+    val exists : (Constr.t -> bool) -> t -> bool
 
-val fold_named_declaration :
-  (Constr.t -> 'a -> 'a) -> named_declaration -> 'a -> 'a
-val fold_rel_declaration :
-  (Constr.t -> 'a -> 'a) -> rel_declaration -> 'a -> 'a
+    (** Check whether all terms in a given declaration satisfy a given predicate. *)
+    val for_all : (Constr.t -> bool) -> t -> bool
 
-val exists_named_declaration :
-  (Constr.t -> bool) -> named_declaration -> bool
-val exists_rel_declaration :
-  (Constr.t -> bool) -> rel_declaration -> bool
+    (** Check whether the two given declarations are equal. *)
+    val equal : t -> t -> bool
 
-val for_all_named_declaration :
-  (Constr.t -> bool) -> named_declaration -> bool
-val for_all_rel_declaration :
-  (Constr.t -> bool) -> rel_declaration -> bool
+    (** Map the identifier bound by a given declaration. *)
+    val map_id : (Id.t -> Id.t) -> t -> t
 
-val eq_named_declaration :
-  named_declaration -> named_declaration -> bool
+    (** For local assumptions, this function returns the original local assumptions.
+        For local definitions, this function maps the value in the local definition. *)
+    val map_value : (Constr.t -> Constr.t) -> t -> t
 
-val eq_rel_declaration :
-    rel_declaration -> rel_declaration -> bool
+    (** Map the type of the name bound by a given declaration. *)
+    val map_type : (Constr.t -> Constr.t) -> t -> t
 
-(** {6 Signatures of ordered named declarations } *)
+    (** Map all terms in a given declaration. *)
+    val map_constr : (Constr.t -> Constr.t) -> t -> t
 
-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 *)
+    (** Perform a given action on all terms in a given declaration. *)
+    val iter_constr : (Constr.t -> unit) -> t -> unit
 
-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
+    (** Reduce all terms in a given declaration to a single value. *)
+    val fold : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a
 
-val lookup_named : Id.t -> named_context -> named_declaration
+    val to_tuple : t -> Id.t * Constr.t option * Constr.t
+    val of_tuple : Id.t * Constr.t option * Constr.t -> t
+  end
 
-(** number of declarations *)
-val named_context_length : named_context -> int
+  (** Rel-context is represented as a list of declarations.
+      Inner-most declarations are at the beginning of the list.
+      Outer-most declarations are at the end of the list. *)
+  type t = Declaration.t list
 
-(** named context equality *)
-val named_context_equal : named_context -> named_context -> bool
+  (** empty named-context *)
+  val empty : t
 
-(** {6 Recurrence on [named_context]: older declarations processed first } *)
-val fold_named_context :
-  (named_declaration -> 'a -> 'a) -> named_context -> init:'a -> 'a
+  (** Return a new rel-context enriched by with a given inner-most declaration. *)
+  val add : Declaration.t -> t -> t
 
-val fold_named_list_context :
-  (named_list_declaration -> 'a -> 'a) -> named_list_context -> init:'a -> 'a
+  (** Return the number of {e local declarations} in a given named-context. *)
+  val length : t -> int
 
-(** newer declarations first *)
-val fold_named_context_reverse :
-  ('a -> named_declaration -> 'a) -> init:'a -> named_context -> 'a
+  (** Return a declaration designated by an identifier of the variable bound in that declaration.
+      @raise Not_found if the designated identifier is not bound in a given named-context. *)
+  val lookup : Id.t -> t -> Declaration.t
 
-(** {6 Section-related auxiliary functions } *)
-val instance_from_named_context : named_context -> Constr.t list
+  (** Check whether given two rel-contexts are equal. *)
+  val equal : t -> t -> bool
 
-(** {6 ... } *)
-(** Signatures of ordered optionally named variables, intended to be
-   accessed by de Bruijn indices *)
+  (** Map all terms in a given named-context. *)
+  val map : (Constr.t -> Constr.t) -> t -> t
 
-(** {6 Recurrence on [rel_context]: older declarations processed first } *)
-val fold_rel_context :
-  (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a
+  (** Perform a given action on every declaration in a given named-context. *)
+  val iter : (Constr.t -> unit) -> t -> unit
 
-(** newer declarations first *)
-val fold_rel_context_reverse :
-  ('a -> rel_declaration -> 'a) -> init:'a -> rel_context -> 'a
+  (** Reduce all terms in a given named-context to a single value.
+      Innermost declarations are processed first. *)
+  val fold_inside : ('a -> Declaration.t -> 'a) -> init:'a -> t -> 'a
 
-(** {6 Map function of [rel_context] } *)
-val map_rel_context : (Constr.t -> Constr.t) -> rel_context -> rel_context
+  (** Reduce all terms in a given named-context to a single value.
+      Outermost declarations are processed first. *)
+  val fold_outside : (Declaration.t -> 'a -> 'a) -> t -> init:'a -> 'a
 
-(** {6 Map function of [named_context] } *)
-val map_named_context : (Constr.t -> Constr.t) -> named_context -> named_context
+  (** Return the set of all identifiers bound in a given named-context. *)
+  val to_vars : t -> Id.Set.t
 
-(** {6 Map function of [rel_context] } *)
-val iter_rel_context : (Constr.t -> unit) -> rel_context -> unit
+  (** [instance_from_named_context Ω] builds an instance [args] such
+      that [Ω ⊢ args:Ω] where [Ω] is a named context and with the local
+      definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it
+      gives [Var id1, Var id3]. All [idj] are supposed distinct. *)
+  val to_instance : t -> Constr.t list
+end
 
-(** {6 Map function of [named_context] } *)
-val iter_named_context : (Constr.t -> unit) -> named_context -> unit
+module NamedList :
+sig
+  module Declaration :
+  sig
+    type t = Id.t list * Constr.t option * Constr.t
+    val map_constr : (Constr.t -> Constr.t) -> t -> t
+  end
 
-(** {6 Contexts of declarations referred to by de Bruijn indices } *)
+  type t = Declaration.t list
 
-val empty_rel_context : rel_context
-val add_rel_decl : rel_declaration -> rel_context -> rel_context
+  val fold : (Declaration.t -> 'a -> 'a) -> t -> init:'a -> 'a
+end
 
-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
+type section_context = Named.t
diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml
index 462413bd..3f1cf924 100644
--- a/kernel/conv_oracle.ml
+++ b/kernel/conv_oracle.ml
@@ -71,7 +71,7 @@ let set_strategy ({ var_opacity; cst_opacity } as oracle) k l =
     | _ -> Cpred.add c oracle.cst_trstate
     in
     { oracle with cst_opacity; cst_trstate; }
-  | RelKey _ -> Errors.error "set_strategy: RelKey"
+  | RelKey _ -> CErrors.error "set_strategy: RelKey"
 
 let fold_strategy f { var_opacity; cst_opacity; } accu =
   let fvar id lvl accu = f (VarKey id) lvl accu in
diff --git a/kernel/cooking.ml b/kernel/cooking.ml
index f0e92558..13459915 100644
--- a/kernel/cooking.ml
+++ b/kernel/cooking.ml
@@ -13,7 +13,7 @@
 (* This module implements kernel-level discharching of local
    declarations over global constants and inductive types *)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Term
@@ -44,15 +44,15 @@ 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
+  | ConstRef c1, ConstRef c2 -> Constant.SyntacticOrd.equal c1 c2
+  | IndRef i1, IndRef i2 -> eq_syntactic_ind i1 i2
+  | ConstructRef c1, ConstructRef c2 -> eq_syntactic_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)
+  | ConstRef c -> combinesmall 1 (Constant.SyntacticOrd.hash c)
+  | IndRef i -> combinesmall 2 (ind_syntactic_hash i)
+  | ConstructRef c -> combinesmall 3 (constructor_syntactic_hash c)
 end
 
 module RefTable = Hashtbl.Make(RefHash)
@@ -173,7 +173,7 @@ let expmod_constr_subst cache modlist 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
+  let hyps = Context.Named.map expmod (pi1 abstract) in
   abstract_constant_body (expmod c) hyps
 
 let lift_univs cb subst =
@@ -195,14 +195,16 @@ let cook_constant env { from = cb; info } =
   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 hyps = Context.Named.map 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 =
-    Context.fold_named_context (fun (h,_,_) hyps ->
-      List.filter (fun (id,_,_) -> not (Id.equal id h)) hyps)
+    Context.Named.fold_outside (fun decl hyps ->
+      let open Context.Named.Declaration in
+      List.filter (fun decl' -> not (Id.equal (get_id decl) (get_id decl')))
+		  hyps)
       hyps ~init:cb.const_hyps in
   let typ = match cb.const_type with
     | RegularArity t ->
diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml
index fc7e1b93..c27cb048 100644
--- a/kernel/csymtable.ml
+++ b/kernel/csymtable.ml
@@ -15,7 +15,6 @@
 open Util
 open Names
 open Term
-open Context
 open Vm
 open Cemitcodes
 open Cbytecodes
@@ -131,8 +130,8 @@ let key rk =
   match !rk with
   | None -> raise NotEvaluated
   | Some k ->
-      try Ephemeron.get k
-      with Ephemeron.InvalidKey -> raise NotEvaluated
+      try CEphemeron.get k
+      with CEphemeron.InvalidKey -> raise NotEvaluated
 
 (************************)
 (* traduction des patch *)
@@ -171,7 +170,7 @@ let rec slot_for_getglobal env kn =
 	 | BCconstant -> set_global (val_of_constant kn)
     in
 (*Pp.msgnl(str"value stored at: "++int pos);*)
-    rk := Some (Ephemeron.create pos);
+    rk := Some (CEphemeron.create pos);
     pos
 
 and slot_for_fv env fv =
@@ -190,51 +189,39 @@ and slot_for_fv env fv =
       let nv = Pre_env.lookup_named_val id env in
       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
+         let open Context.Named in
+         let open Declaration in
+	 env |> Pre_env.lookup_named id |> get_value |> fill_fv_cache nv id val_of_named idfun
       | Some (v, _) -> v
       end
   | FVrel i ->
       let rv = Pre_env.lookup_rel_val i env in
       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
+         let open Context.Rel in
+         let open Declaration in
+	 env.env_rel_context |> lookup i |> get_value |> fill_fv_cache rv i val_of_rel env_of_rel
       | Some (v, _) -> v
       end
   | FVuniv_var idu ->
     assert false
 
 and eval_to_patch env (buff,pl,fv) =
-  (* copy code *before* patching because of nested evaluations:
-     the code we are patching might be called (and thus "concurrently" patched)
-     and results in wrong results. Side-effects... *)
-  let buff = Cemitcodes.copy buff in
   let patch = function
-    | Reloc_annot a, pos -> patch_int buff pos (slot_for_annot a)
-    | Reloc_const sc, pos -> patch_int buff pos (slot_for_str_cst sc)
-    | Reloc_getglobal kn, pos ->
-(*      Pp.msgnl (str"patching global: "++str(debug_string_of_con kn));*)
-	patch_int buff pos (slot_for_getglobal env kn);
-(*      Pp.msgnl (str"patch done: "++str(debug_string_of_con kn))*)
+    | Reloc_annot a, pos -> (pos, slot_for_annot a)
+    | Reloc_const sc, pos -> (pos, slot_for_str_cst sc)
+    | Reloc_getglobal kn, pos -> (pos, slot_for_getglobal env kn)
   in
-  List.iter patch pl;
+  let patches = List.map_left patch pl in
+  let buff = patch_int buff patches in
   let vm_env = Array.map (slot_for_fv env) fv in
   let tc = tcode_of_code buff (length buff) in
   eval_tcode tc vm_env
 
 and val_of_constr env c =
-  let (_,fun_code,_ as ccfv) =
-    try match compile true env c with
-	| Some v -> v
-	| None -> assert false
-    with 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)
+  match compile true env c with
+  | Some v -> eval_to_patch env (to_memory v)
+  | None -> assert false
 
 let set_transparent_const kn = () (* !?! *)
 let set_opaque_const kn = () (* !?! *)
diff --git a/kernel/declarations.mli b/kernel/declarations.mli
index de966daa..f89773fc 100644
--- a/kernel/declarations.mli
+++ b/kernel/declarations.mli
@@ -8,16 +8,14 @@
 
 open Names
 open Term
-open Context
 
 (** This module defines the internal representation of global
    declarations. This includes global constants/axioms, mutual
    inductive definitions, modules and module types *)
 
 type set_predicativity = ImpredicativeSet | PredicativeSet
-type type_hierarchy = TypeInType | StratifiedType
 
-type engagement = set_predicativity * type_hierarchy
+type engagement = set_predicativity
 
 (** {6 Representation of constants (Definition/Axiom) } *)
 
@@ -38,7 +36,7 @@ type ('a, 'b) declaration_arity =
   | RegularArity of 'a
   | TemplateArity of 'b
 
-type constant_type = (types, rel_context * template_arity) declaration_arity
+type constant_type = (types, Context.Rel.t * template_arity) declaration_arity
 
 (** Inlining level of parameters at functor applications.
     None means no inlining *)
@@ -67,6 +65,16 @@ type constant_def =
 
 type constant_universes = Univ.universe_context
 
+(** The [typing_flags] are instructions to the type-checker which
+    modify its behaviour. The typing flags used in the type-checking
+    of a constant are tracked in their {!constant_body} so that they
+    can be displayed to the user. *)
+type typing_flags = {
+  check_guarded : bool; (** If [false] then fixed points and co-fixed
+                            points are assumed to be total. *)
+  check_universes : bool; (** If [false] universe constraints are not checked *)
+}
+
 (* some contraints are in constant_constraints, some other may be in
  * the OpaueDef *)
 type constant_body = {
@@ -77,7 +85,11 @@ type constant_body = {
     const_polymorphic : bool; (** Is it polymorphic or not *)
     const_universes : constant_universes;
     const_proj : projection_body option;
-    const_inline_code : bool }
+    const_inline_code : bool;
+    const_typing_flags : typing_flags; (** The typing options which
+                                           were used for
+                                           type-checking. *)
+}
 
 (** {6 Representation of mutual inductive types in the kernel } *)
 
@@ -117,7 +129,7 @@ type one_inductive_body = {
 
     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_ctxt : Context.Rel.t; (** Arity context of [Ii] with parameters: [forall params, Ui] *)
 
     mind_arity : inductive_arity; (** Arity sort and original user arity *)
 
@@ -171,14 +183,15 @@ type mutual_inductive_body = {
 
     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_params_ctxt : Context.Rel.t;  (** 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 *)
-  
+
+    mind_typing_flags : typing_flags; (** typing flags at the time of the inductive creation *)
 }
 
 (** {6 Module declarations } *)
diff --git a/kernel/declareops.ml b/kernel/declareops.ml
index d9bd5c44..211e5e06 100644
--- a/kernel/declareops.ml
+++ b/kernel/declareops.ml
@@ -9,10 +9,16 @@
 open Declarations
 open Mod_subst
 open Util
+open Context.Rel.Declaration
 
 (** Operations concernings types in [Declarations] :
     [constant_body], [mutual_inductive_body], [module_body] ... *)
 
+let safe_flags = {
+  check_guarded = true;
+  check_universes = true;
+}
+
 (** {6 Arities } *)
 
 let subst_decl_arity f g sub ar = 
@@ -87,10 +93,8 @@ let is_opaque cb = match cb.const_body with
 
 (** {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_declaration sub =
+  map_constr (subst_mps sub)
 
 let subst_rel_context sub = List.smartmap (subst_rel_declaration sub)
 
@@ -132,7 +136,8 @@ let subst_const_body sub cb =
           Option.map (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 }
+        const_inline_code = cb.const_inline_code;
+        const_typing_flags = cb.const_typing_flags }
 
 (** {7 Hash-consing of constants } *)
 
@@ -140,11 +145,8 @@ let subst_const_body sub cb =
     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_decl =
+  map_type Term.hcons_types % map_value Term.hcons_constr % map_name Names.Name.hcons
 
 let hcons_rel_context l = List.smartmap hcons_rel_decl l
 
@@ -254,11 +256,13 @@ let subst_mind_body sub mib =
     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;
+      Context.Rel.map (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 }
+    mind_private = mib.mind_private;
+    mind_typing_flags = mib.mind_typing_flags;
+  }
 
 let inductive_instance mib =
   if mib.mind_polymorphic then
@@ -308,3 +312,86 @@ let string_of_side_effect { Entries.eff } = match eff with
   | Entries.SEsubproof (c,_,_) -> "P(" ^ Names.string_of_con c ^ ")"
   | Entries.SEscheme (cl,_) ->
       "S(" ^ String.concat ", " (List.map (fun (_,c,_,_) -> Names.string_of_con c) cl) ^ ")"
+
+(** Hashconsing of modules *)
+
+let hcons_functorize hty he hself f = match f with
+| NoFunctor e ->
+  let e' = he e in
+  if e == e' then f else NoFunctor e'
+| MoreFunctor (mid, ty, nf) ->
+  (** FIXME *)
+  let mid' = mid in
+  let ty' = hty ty in
+  let nf' = hself nf in
+  if mid == mid' && ty == ty' && nf == nf' then f
+  else MoreFunctor (mid, ty', nf')
+
+let hcons_module_alg_expr me = me
+
+let rec hcons_structure_field_body sb = match sb with
+| SFBconst cb ->
+  let cb' = hcons_const_body cb in
+  if cb == cb' then sb else SFBconst cb'
+| SFBmind mib ->
+  let mib' = hcons_mind mib in
+  if mib == mib' then sb else SFBmind mib'
+| SFBmodule mb ->
+  let mb' = hcons_module_body mb in
+  if mb == mb' then sb else SFBmodule mb'
+| SFBmodtype mb ->
+  let mb' = hcons_module_body mb in
+  if mb == mb' then sb else SFBmodtype mb'
+
+and hcons_structure_body sb =
+  (** FIXME *)
+  let map (l, sfb as fb) =
+    let l' = Names.Label.hcons l in
+    let sfb' = hcons_structure_field_body sfb in
+    if l == l' && sfb == sfb' then fb else (l', sfb')
+  in
+  List.smartmap map sb
+
+and hcons_module_signature ms =
+  hcons_functorize hcons_module_body hcons_structure_body hcons_module_signature ms
+
+and hcons_module_expression me =
+  hcons_functorize hcons_module_body hcons_module_alg_expr hcons_module_expression me
+
+and hcons_module_implementation mip = match mip with
+| Abstract -> Abstract
+| Algebraic me ->
+  let me' = hcons_module_expression me in
+  if me == me' then mip else Algebraic me'
+| Struct ms ->
+  let ms' = hcons_module_signature ms in
+  if ms == ms' then mip else Struct ms
+| FullStruct -> FullStruct
+
+and hcons_module_body mb =
+  let mp' = mb.mod_mp in
+  let expr' = hcons_module_implementation mb.mod_expr in
+  let type' = hcons_module_signature mb.mod_type in
+  let type_alg' = mb.mod_type_alg in
+  let constraints' = Univ.hcons_universe_context_set mb.mod_constraints in
+  let delta' = mb.mod_delta in
+  let retroknowledge' = mb.mod_retroknowledge in
+
+  if
+    mb.mod_mp == mp' &&
+    mb.mod_expr == expr' &&
+    mb.mod_type == type' &&
+    mb.mod_type_alg == type_alg' &&
+    mb.mod_constraints == constraints' &&
+    mb.mod_delta == delta' &&
+    mb.mod_retroknowledge == retroknowledge'
+  then mb
+  else {
+    mod_mp = mp';
+    mod_expr = expr';
+    mod_type = type';
+    mod_type_alg = type_alg';
+    mod_constraints = constraints';
+    mod_delta = delta';
+    mod_retroknowledge = retroknowledge';
+  }
diff --git a/kernel/declareops.mli b/kernel/declareops.mli
index 86ba29b8..6650b6b7 100644
--- a/kernel/declareops.mli
+++ b/kernel/declareops.mli
@@ -69,6 +69,11 @@ val subst_mind_body : substitution -> mutual_inductive_body -> mutual_inductive_
 val inductive_instance : mutual_inductive_body -> universe_instance
 val inductive_context : mutual_inductive_body -> universe_context
 
+(** {6 Kernel flags} *)
+
+(** A default, safe set of flags for kernel type-checking *)
+val safe_flags : typing_flags
+
 (** {6 Hash-consing} *)
 
 (** Here, strictly speaking, we don't perform true hash-consing
@@ -77,3 +82,4 @@ val inductive_context : mutual_inductive_body -> universe_context
 
 val hcons_const_body : constant_body -> constant_body
 val hcons_mind : mutual_inductive_body -> mutual_inductive_body
+val hcons_module_body : module_body -> module_body
diff --git a/kernel/entries.mli b/kernel/entries.mli
index b2a77dd9..ea7c266b 100644
--- a/kernel/entries.mli
+++ b/kernel/entries.mli
@@ -18,8 +18,8 @@ open Term
 (** {6 Local entries } *)
 
 type local_entry =
-  | LocalDef of constr
-  | LocalAssum of constr
+  | LocalDefEntry of constr
+  | LocalAssumEntry of constr
 
 
 (** {6 Declaration of inductive types. } *)
@@ -51,7 +51,8 @@ type mutual_inductive_entry = {
   mind_entry_inds : one_inductive_entry list;
   mind_entry_polymorphic : bool; 
   mind_entry_universes : Univ.universe_context;
-  mind_entry_private : bool option }
+  mind_entry_private : bool option;
+}
 
 (** {6 Constants (Definition/Axiom) } *)
 type 'a proof_output = constr Univ.in_universe_context_set * 'a
@@ -97,14 +98,19 @@ type module_entry =
   | MExpr of
       module_params_entry * module_struct_entry * module_struct_entry option
 
-type seff_env = [ `Nothing | `Opaque of Constr.t * Univ.universe_context_set ]
+
+type seff_env =
+  [ `Nothing
+  (* The proof term and its universes.
+     Same as the constant_body's but not in an ephemeron *)
+  | `Opaque of Constr.t * Univ.universe_context_set ]
 
 type side_eff =
   | SEsubproof of constant * Declarations.constant_body * seff_env
   | SEscheme of (inductive * constant * Declarations.constant_body * seff_env) list * string
 
 type side_effect = {
-  from_env : Declarations.structure_body Ephemeron.key;
+  from_env : Declarations.structure_body CEphemeron.key;
   eff      : side_eff;
 }
 
diff --git a/kernel/environ.ml b/kernel/environ.ml
index cd376b69..16ddfac6 100644
--- a/kernel/environ.ml
+++ b/kernel/environ.ml
@@ -20,14 +20,14 @@
 (* This file defines the type of environments on which the
    type-checker works, together with simple related functions *)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Term
-open Context
 open Vars
 open Declarations
 open Pre_env
+open Context.Rel.Declaration
 
 (* The type of environments. *)
 
@@ -45,46 +45,43 @@ let empty_named_context_val = empty_named_context_val
 let empty_env = empty_env
 
 let engagement env = env.env_stratification.env_engagement
+let typing_flags env = env.env_typing_flags
 
 let is_impredicative_set env = 
-  match fst (engagement env) with
+  match engagement env with
   | ImpredicativeSet -> true
   | _ -> false
 
-let type_in_type env =
-  match snd (engagement env) with
-  | TypeInType -> true
-  | _ -> false
+let type_in_type env = not (typing_flags env).check_universes
+let deactivated_guard env = not (typing_flags env).check_guarded
 
 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 named_context env = env.env_named_context.env_named_ctx
+let named_context_val env = env.env_named_context
 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 =
-  match env.env_rel_context, env.env_named_context with
+  match env.env_rel_context, env.env_named_context.env_named_ctx with
   | [], [] -> true
   | _ -> false
 
 (* Rel context *)
 let lookup_rel n env =
-  lookup_rel n env.env_rel_context
+  Context.Rel.lookup n env.env_rel_context
 
 let evaluable_rel n env =
-  match lookup_rel n env with
-  | (_,Some _,_) -> true
-  | _ -> false
+  is_local_def (lookup_rel n env)
 
 let nb_rel env = env.env_nb_rel
 
 let push_rel = push_rel
 
-let push_rel_context ctxt x = Context.fold_rel_context push_rel ctxt ~init:x
+let push_rel_context ctxt x = Context.Rel.fold_outside 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 -> LocalAssum (na, 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 =
@@ -102,25 +99,14 @@ let fold_rel_context f env ~init =
 
 (* Named context *)
 
-let named_context_of_val = fst
-let named_vals_of_val = snd
+let named_context_of_val c = c.env_named_ctx
 
 (* [map_named_val f ctxt] apply [f] to the body and the type of
    each declarations.
    *** /!\ ***   [f t] should be convertible with t *)
-let map_named_val f (ctxt,ctxtv) =
-  let 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 map_named_val = map_named_val
 
-let empty_named_context = empty_named_context
+let empty_named_context = Context.Named.empty
 
 let push_named = push_named
 let push_named_context = List.fold_right push_named
@@ -130,30 +116,31 @@ let val_of_named_context ctxt =
   List.fold_right push_named_context_val ctxt empty_named_context_val
 
 
-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 lookup_named = lookup_named
+let lookup_named_val id ctxt = fst (Id.Map.find id ctxt.env_named_map)
 
 let eq_named_context_val c1 c2 =
-   c1 == c2 || named_context_equal (named_context_of_val c1) (named_context_of_val c2)
+   c1 == c2 || Context.Named.equal (named_context_of_val c1) (named_context_of_val c2)
 
 (* A local const is evaluable if it is defined  *)
 
+open Context.Named.Declaration
+
 let named_type id env =
-  let (_,_,t) = lookup_named id env in t
+  get_type (lookup_named id env)
 
 let named_body id env =
-  let (_,b,_) = lookup_named id env in b
+  get_value (lookup_named id env)
 
 let evaluable_named id env =
   match named_body id env with
   | Some _      -> true
   | _          -> false
 
-let reset_with_named_context (ctxt,ctxtv) env =
+let reset_with_named_context ctxt env =
   { env with
     env_named_context = ctxt;
-    env_named_vals = ctxtv;
-    env_rel_context = empty_rel_context;
+    env_rel_context = Context.Rel.empty;
     env_rel_val = [];
     env_nb_rel = 0 }
 
@@ -167,16 +154,16 @@ let pop_rel_context n env =
 
 let fold_named_context f env ~init =
   let rec fold_right env =
-    match env.env_named_context with
-    | [] -> init
-    | d::ctxt ->
+    match match_named_context_val env.env_named_context with
+    | None -> init
+    | Some (d, v, rem) ->
 	let env =
-	  reset_with_named_context (ctxt,List.tl env.env_named_vals) env in
+	  reset_with_named_context rem env in
 	f env d (fold_right env)
   in fold_right env
 
 let fold_named_context_reverse f ~init env =
-  Context.fold_named_context_reverse f ~init:init (named_context env)
+  Context.Named.fold_inside f ~init:init (named_context env)
 
 
 (* Universe constraints *)
@@ -188,10 +175,10 @@ let map_universes f env =
 				     
 let add_constraints c env =
   if Univ.Constraint.is_empty c then env
-  else map_universes (Univ.merge_constraints c) env
+  else map_universes (UGraph.merge_constraints c) env
 
 let check_constraints c env =
-  Univ.check_constraints c env.env_stratification.env_universes
+  UGraph.check_constraints c env.env_stratification.env_universes
 
 let push_constraints_to_env (_,univs) env =
   add_constraints univs env
@@ -199,19 +186,19 @@ let push_constraints_to_env (_,univs) env =
 let add_universes strict ctx g =
   let g = Array.fold_left
 	    (* Be lenient, module typing reintroduces universes and constraints due to includes *)
-	    (fun g v -> try Univ.add_universe v strict g with Univ.AlreadyDeclared -> g)
+	    (fun g v -> try UGraph.add_universe v strict g with UGraph.AlreadyDeclared -> g)
 	    g (Univ.Instance.to_array (Univ.UContext.instance ctx))
   in
-    Univ.merge_constraints (Univ.UContext.constraints ctx) g
+    UGraph.merge_constraints (Univ.UContext.constraints ctx) g
 			   
 let push_context ?(strict=false) ctx env =
   map_universes (add_universes strict ctx) env
 
 let add_universes_set strict ctx g =
   let g = Univ.LSet.fold
-	    (fun v g -> try Univ.add_universe v strict g with Univ.AlreadyDeclared -> g)
+	    (fun v g -> try UGraph.add_universe v strict g with UGraph.AlreadyDeclared -> g)
 	    (Univ.ContextSet.levels ctx) g
-  in Univ.merge_constraints (Univ.ContextSet.constraints ctx) g
+  in UGraph.merge_constraints (Univ.ContextSet.constraints ctx) g
 
 let push_context_set ?(strict=false) ctx env =
   map_universes (add_universes_set strict ctx) env
@@ -220,6 +207,9 @@ let set_engagement c env = (* Unsafe *)
   { env with env_stratification =
     { env.env_stratification with env_engagement = c } }
 
+let set_typing_flags c env = (* Unsafe *)
+  { env with env_typing_flags = c }
+
 (* Global constants *)
 
 let lookup_constant = lookup_constant
@@ -337,6 +327,9 @@ let polymorphic_pconstant (cst,u) env =
   if Univ.Instance.is_empty u then false
   else polymorphic_constant cst env
 
+let type_in_type_constant cst env =
+  not (lookup_constant cst env).const_typing_flags.check_universes
+
 let template_polymorphic_constant cst env =
   match (lookup_constant cst env).const_type with 
   | TemplateArity _ -> true
@@ -366,6 +359,9 @@ let polymorphic_pind (ind,u) env =
   if Univ.Instance.is_empty u then false
   else polymorphic_ind ind env
 
+let type_in_type_ind (mind,i) env =
+  not (lookup_mind mind env).mind_typing_flags.check_universes
+
 let template_polymorphic_ind (mind,i) env =
   match (lookup_mind mind env).mind_packets.(i).mind_arity with 
   | TemplateArity _ -> true
@@ -389,11 +385,11 @@ let add_mind kn mib env =
 
 let lookup_constant_variables c env =
   let cmap = lookup_constant c env in
-  Context.vars_of_named_context cmap.const_hyps
+  Context.Named.to_vars cmap.const_hyps
 
 let lookup_inductive_variables (kn,i) env =
   let mis = lookup_mind kn env in
-  Context.vars_of_named_context mis.mind_hyps
+  Context.Named.to_vars mis.mind_hyps
 
 let lookup_constructor_variables (ind,_) env =
   lookup_inductive_variables ind env
@@ -427,15 +423,15 @@ let global_vars_set env constr =
    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
+  Context.Named.fold_inside
+    (fun need decl ->
+      if Id.Set.mem (get_id decl) need then
         let globc =
-          match copt with
-            | None -> Id.Set.empty
-            | Some c -> global_vars_set env c in
+          match decl with
+            | LocalAssum _ -> Id.Set.empty
+            | LocalDef (_,c,_) -> global_vars_set env c in
         Id.Set.union
-          (global_vars_set env t)
+          (global_vars_set env (get_type decl))
           (Id.Set.union globc need)
       else need)
     ~init:needed
@@ -443,9 +439,9 @@ let really_needed env needed =
 
 let keep_hyps env needed =
   let really_needed = really_needed env needed in
-  Context.fold_named_context
-    (fun (id,_,_ as d) nsign ->
-      if Id.Set.mem id really_needed then add_named_decl d nsign
+  Context.Named.fold_outside
+    (fun d nsign ->
+      if Id.Set.mem (get_id d) really_needed then Context.Named.add d nsign
       else nsign)
     (named_context env)
     ~init:empty_named_context
@@ -494,66 +490,35 @@ let compile_constant_body = Cbytegen.compile_constant_body false
 
 exception Hyp_not_found
 
-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 Id.equal idc id then
-	  (f ctxt d rtail)::ctxt, v::vals
+let apply_to_hyp ctxt id f =
+  let rec aux rtail ctxt =
+    match match_named_context_val ctxt with
+    | Some (d, v, ctxt) ->
+	if Id.equal (get_id d) id then
+          push_named_context_val_val (f ctxt.env_named_ctx d rtail) v ctxt
 	else
-	  let ctxt',vals' = aux (d::rtail) ctxt vals in
-	  d::ctxt', v::vals'
-    | [],[] -> raise Hyp_not_found
-    | _, _ -> assert false
-  in aux [] ctxt vals
-
-let 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 Id.equal idc id then
-	  let sign = ctxt,vals in
-	  push_named_context_val (f d sign) sign
-	else
-	  let (ctxt,vals as sign) = aux ctxt vals in
-	  push_named_context_val (g d sign) sign
-    | [],[] -> raise Hyp_not_found
-    | _,_ -> assert false
-  in aux ctxt vals
-
-let insert_after_hyp (ctxt,vals) id d check =
-  let rec aux ctxt vals =
-    match  ctxt, vals with
-    | (idc,c,ct)::ctxt', v::vals' ->
-	if Id.equal idc id then begin
-	  check ctxt;
-	  push_named_context_val d (ctxt,vals)
-	end else
-	  let ctxt,vals = aux ctxt vals in
-	  d::ctxt, v::vals
-    | [],[] -> raise Hyp_not_found
-    | _, _ -> assert false
-  in aux ctxt vals
-
+	  let ctxt' = aux (d::rtail) ctxt in
+	  push_named_context_val_val d v ctxt'
+    | None -> raise Hyp_not_found
+  in aux [] ctxt
 
 (* To be used in Logic.clear_hyps *)
-let remove_hyps ids check_context check_value (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
+let remove_hyps ids check_context check_value ctxt =
+  let rec remove_hyps ctxt = match match_named_context_val ctxt with
+  | None -> empty_named_context_val, false
+  | Some (d, v, rctxt) ->
+    let (ans, seen) = remove_hyps rctxt in
+    if Id.Set.mem (get_id d) ids then (ans, true)
+    else if not seen then ctxt, false
     else
-      let (rctxt', rvals') = ans in
+      let rctxt' = 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
+      if d == d' && v == v' && rctxt == rctxt' then
+        ctxt, true
+      else push_named_context_val_val d' v' rctxt', true
   in
-  remove_hyps ctxt vals
+  fst (remove_hyps ctxt)
 
 (*spiwack: the following functions assemble the pieces of the retroknowledge
    note that the "consistent" register function is available in the module
@@ -602,7 +567,10 @@ let dispatch =
 	  Array.init 31 (fun n -> mkConstruct
 			   (digit_ind, nth_digit_plus_one i (30-n)))
 	in
-	  mkApp(mkConstruct(ind, 1), array_of_int tag)
+	(* We check that no bit above 31 is set to one. This assertion used to
+	fail in the VM, and led to conversion tests failing at Qed. *)
+        assert (Int.equal (tag lsr 31) 0);
+	mkApp(mkConstruct(ind, 1), array_of_int tag)
   in
 
   (* subfunction which dispatches the compiling information of an
diff --git a/kernel/environ.mli b/kernel/environ.mli
index c3354f55..6ac00088 100644
--- a/kernel/environ.mli
+++ b/kernel/environ.mli
@@ -8,7 +8,6 @@
 
 open Names
 open Term
-open Context
 open Declarations
 open Univ
 
@@ -41,9 +40,9 @@ val eq_named_context_val : named_context_val -> named_context_val -> bool
 
 val empty_env : env
 
-val universes     : env -> Univ.universes
-val rel_context   : env -> rel_context
-val named_context : env -> named_context
+val universes     : env -> UGraph.t
+val rel_context   : env -> Context.Rel.t
+val named_context : env -> Context.Named.t
 val named_context_val : env -> named_context_val
 
 val opaque_tables : env -> Opaqueproof.opaquetab
@@ -51,8 +50,10 @@ val set_opaque_tables : env -> Opaqueproof.opaquetab -> env
 
 
 val engagement    : env -> engagement
+val typing_flags    : env -> typing_flags
 val is_impredicative_set : env -> bool
 val type_in_type : env -> bool
+val deactivated_guard : env -> bool
 
 (** is the local context empty *)
 val empty_context : env -> bool
@@ -60,25 +61,24 @@ val empty_context : env -> bool
 (** {5 Context of de Bruijn variables ([rel_context]) } *)
 
 val nb_rel           : env -> int
-val push_rel         : rel_declaration -> env -> env
-val push_rel_context :     rel_context -> env -> env
+val push_rel         : Context.Rel.Declaration.t -> env -> env
+val push_rel_context : Context.Rel.t -> env -> env
 val push_rec_types   : rec_declaration -> env -> env
 
 (** Looks up in the context of local vars referred by indice ([rel_context]) 
    raises [Not_found] if the index points out of the context *)
-val lookup_rel    : int -> env -> rel_declaration
+val lookup_rel    : int -> env -> Context.Rel.Declaration.t
 val evaluable_rel : int -> env -> bool
 
 (** {6 Recurrence on [rel_context] } *)
 
 val fold_rel_context :
-  (env -> rel_declaration -> 'a -> 'a) -> env -> init:'a -> 'a
+  (env -> Context.Rel.Declaration.t -> 'a -> 'a) -> env -> init:'a -> 'a
 
 (** {5 Context of variables (section variables and goal assumptions) } *)
 
-val named_context_of_val : named_context_val -> named_context
-val named_vals_of_val : named_context_val -> Pre_env.named_vals
-val val_of_named_context : named_context -> named_context_val
+val named_context_of_val : named_context_val -> Context.Named.t
+val val_of_named_context : Context.Named.t -> named_context_val
 val empty_named_context_val : named_context_val
 
 
@@ -88,18 +88,18 @@ val empty_named_context_val : named_context_val
 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.Named.Declaration.t -> env -> env
+val push_named_context : Context.Named.t -> env -> env
 val push_named_context_val  :
-    named_declaration -> named_context_val -> named_context_val
+    Context.Named.Declaration.t -> named_context_val -> named_context_val
 
 
 
 (** Looks up in the context of local vars referred by names ([named_context]) 
    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
+val lookup_named     : variable -> env -> Context.Named.Declaration.t
+val lookup_named_val : variable -> named_context_val -> Context.Named.Declaration.t
 val evaluable_named  : variable -> env -> bool
 val named_type : variable -> env -> types
 val named_body : variable -> env -> constr option
@@ -107,11 +107,11 @@ val named_body : variable -> env -> constr option
 (** {6 Recurrence on [named_context]: older declarations processed first } *)
 
 val fold_named_context :
-  (env -> named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a
+  (env -> Context.Named.Declaration.t -> 'a -> 'a) -> env -> init:'a -> 'a
 
 (** Recurrence on [named_context] starting from younger decl *)
 val fold_named_context_reverse :
-  ('a -> named_declaration -> 'a) -> init:'a -> env -> 'a
+  ('a -> Context.Named.Declaration.t -> 'a) -> init:'a -> env -> 'a
 
 (** This forgets named and rel contexts *)
 val reset_context : env -> env
@@ -137,6 +137,7 @@ val evaluable_constant : constant -> env -> bool
 (** New-style polymorphism *)
 val polymorphic_constant  : constant -> env -> bool
 val polymorphic_pconstant : pconstant -> env -> bool
+val type_in_type_constant : constant -> env -> bool
 
 (** Old-style polymorphism *)
 val template_polymorphic_constant  : constant -> env -> bool
@@ -184,6 +185,7 @@ val lookup_mind : mutual_inductive -> env -> mutual_inductive_body
 (** New-style polymorphism *)
 val polymorphic_ind  : inductive -> env -> bool
 val polymorphic_pind : pinductive -> env -> bool
+val type_in_type_ind : inductive -> env -> bool
 
 (** Old-style polymorphism *)
 val template_polymorphic_ind : inductive -> env -> bool
@@ -213,6 +215,7 @@ val push_context_set : ?strict:bool -> Univ.universe_context_set -> env -> env
 val push_constraints_to_env : 'a Univ.constrained -> env -> env
 
 val set_engagement : engagement -> env -> env
+val set_typing_flags : typing_flags -> env -> env
 
 (** {6 Sets of referred section variables }
    [global_vars_set env c] returns the list of [id]'s occurring either
@@ -228,7 +231,7 @@ val vars_of_global : env -> constr -> Id.Set.t
 val really_needed : env -> Id.Set.t -> Id.Set.t
 
 (** like [really_needed] but computes a well ordered named context *)
-val keep_hyps : env -> Id.Set.t -> section_context
+val keep_hyps : env -> Id.Set.t -> Context.section_context
 
 (** {5 Unsafe judgments. }
     We introduce here the pre-type of judgments, which is
@@ -258,22 +261,10 @@ exception Hyp_not_found
    return [tail::(f head (id,_,_) (rev tail))::head].
    the value associated to id should not change *)
 val apply_to_hyp : named_context_val -> variable ->
-  (named_context -> named_declaration -> named_context -> named_declaration) ->
+  (Context.Named.t -> Context.Named.Declaration.t -> Context.Named.t -> Context.Named.Declaration.t) ->
     named_context_val
 
-(** [apply_to_hyp_and_dependent_on sign id f g] split [sign] into
-   [tail::(id,_,_)::head] and
-   return [(g tail)::(f (id,_,_))::head]. *)
-val apply_to_hyp_and_dependent_on : named_context_val -> variable ->
-  (named_declaration -> named_context_val -> named_declaration) ->
-    (named_declaration -> named_context_val -> named_declaration) ->
-      named_context_val
-
-val insert_after_hyp : named_context_val -> variable ->
-  named_declaration ->
-    (named_context -> unit) -> named_context_val
-
-val remove_hyps : Id.Set.t -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val
+val remove_hyps : Id.Set.t -> (Context.Named.Declaration.t -> Context.Named.Declaration.t) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val
 
 
 
diff --git a/kernel/fast_typeops.ml b/kernel/fast_typeops.ml
index 2a6a55ad..bd91c689 100644
--- a/kernel/fast_typeops.ml
+++ b/kernel/fast_typeops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Univ
@@ -35,12 +35,12 @@ let check_constraints cst env =
 
 (* This should be a type (a priori without intention to be an assumption) *)
 let type_judgment env c t =
-  match kind_of_term(whd_betadeltaiota env t) with
+  match kind_of_term(whd_all 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
+  match kind_of_term(whd_all env t) with
   | Sort s -> s
   | _ -> error_not_type env (make_judge c t)
 
@@ -73,8 +73,8 @@ let judge_of_type u =
 
 let judge_of_relative env n =
   try
-    let (_,_,typ) = lookup_rel n env in
-      lift n typ
+    let open Context.Rel.Declaration in
+    env |> lookup_rel n |> get_type |> lift n
   with Not_found ->
     error_unbound_rel env n
 
@@ -90,8 +90,11 @@ let judge_of_variable env id =
    variables of the current env *)
 (* TODO: check order? *)
 let check_hyps_inclusion env f c sign =
-  Context.fold_named_context
-    (fun (id,_,ty1) () ->
+  Context.Named.fold_outside
+    (fun decl () ->
+      let open Context.Named.Declaration in
+      let id = get_id decl in
+      let ty1 = get_type decl in
       try
         let ty2 = named_type id env in
         if not (eq_constr ty2 ty1) then raise Exit
@@ -154,7 +157,7 @@ let judge_of_apply env func funt argsv argstv =
   let rec apply_rec i typ = 
     if Int.equal i len then typ
     else 
-      (match kind_of_term (whd_betadeltaiota env typ) with
+      (match kind_of_term (whd_all env typ) with
       | Prod (_,c1,c2) ->
 	let arg = argsv.(i) and argt = argstv.(i) in
 	  (try
@@ -325,6 +328,7 @@ let type_fixpoint env lna lar vdef vdeft =
     Ind et Constructsi un jour cela devient des constructions
     arbitraires et non plus des variables *)
 let rec execute env cstr =
+  let open Context.Rel.Declaration in
   match kind_of_term cstr with
     (* Atomic terms *)
     | Sort (Prop c) ->
@@ -361,20 +365,20 @@ let rec execute env cstr =
 	      judge_of_constant_knowing_parameters env cst args
 	  | _ ->
 	    (* Full or no sort-polymorphism *)
-	    execute env f
+            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 env1 = push_rel (LocalAssum (name,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 env1 = push_rel (LocalAssum (name,c1)) env in
       let vars' = execute_is_type env1 c2 in
 	judge_of_product env name vars vars'
 
@@ -382,7 +386,7 @@ let rec execute env cstr =
       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 env1 = push_rel (LocalDef (name,c1,c2)) env in
       let c3t = execute env1 c3 in
 	subst1 c1 c3t
 
@@ -448,8 +452,8 @@ let infer env constr =
 let infer = 
   if Flags.profile then
     let infer_key = Profile.declare_profile "Fast_infer" in
-      Profile.profile2 infer_key infer
-  else infer
+      Profile.profile2 infer_key (fun b c -> infer b c)
+  else (fun b c -> infer b c)
 
 let infer_type env constr =
   execute_type env constr
diff --git a/kernel/fast_typeops.mli b/kernel/fast_typeops.mli
index 05d52b2d..41cff607 100644
--- a/kernel/fast_typeops.mli
+++ b/kernel/fast_typeops.mli
@@ -8,6 +8,7 @@
 
 open Term
 open Environ
+open Declarations
 
 (** {6 Typing functions (not yet tagged as safe) }
     
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index f9c2a7b0..de97268b 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -6,13 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Univ
 open Term
 open Vars
-open Context
 open Declarations
 open Declareops
 open Inductive
@@ -21,6 +20,17 @@ open Reduction
 open Typeops
 open Entries
 open Pp
+open Context.Rel.Declaration
+
+(* Terminology:
+paramdecls (ou paramsctxt?)
+args = params + realargs (called vargs when an array, largs when a list)
+params = recparams + nonrecparams
+nonrecargs = nonrecparams + realargs
+env_ar = initial env + declaration of inductive types
+env_ar_par = env_ar + declaration of parameters
+nmr = ongoing computation of recursive parameters
+*)
 
 (* Tell if indices (aka real arguments) contribute to size of inductive type *)
 (* If yes, this is compatible with the univalent model *)
@@ -30,12 +40,17 @@ 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...  *)
+(* [weaker_noccur_between env n nvars t] (defined above), checks that
+   no de Bruijn indices between [n] and [n+nvars] occur in [t]. If
+   some such occurrences are found, then reduction is performed
+   (lazily for efficiency purposes) in order to determine whether
+   these occurrences are occurrences in the normal form. If the
+   occurrences are eliminated a witness reduct [Some t'] of [t] is
+   returned otherwise [None] is returned. *)
 let weaker_noccur_between env x nvars t =
   if noccur_between x nvars t then Some t
   else
-   let t' = whd_betadeltaiota env t in
+   let t' = whd_all env t in
    if noccur_between x nvars t' then Some t'
    else None
 
@@ -114,11 +129,11 @@ let is_unit constrsinfos =
 
 let infos_and_sort env t =
   let rec aux env t max =
-    let t = whd_betadeltaiota env t in
+    let t = whd_all 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 env1 = Environ.push_rel (LocalAssum (name,varj.utj_val)) env in
 	let max = Universe.sup max (univ_of_sort varj.utj_type) in
 	  aux env1 c2 max
     | _ when is_constructor_head t -> max
@@ -164,12 +179,14 @@ let infer_constructor_packet env_ar_par params lc =
 (* If indices matter *)
 let cumulate_arity_large_levels env sign =
   fst (List.fold_right
-    (fun (_,b,t as d) (lev,env) ->
-      if Option.is_empty b then
+    (fun d (lev,env) ->
+     match d with
+     | LocalAssum (_,t) ->
 	let tj = infer_type env t in
 	let u = univ_of_sort tj.utj_type in
 	  (Universe.sup u lev, push_rel d env)
-      else lev, push_rel d env)
+     | LocalDef _ ->
+	lev, push_rel d env)
     sign (Universe.type0m,env))
 
 let is_impredicative env u =
@@ -179,15 +196,16 @@ let is_impredicative env u =
    polymorphism. The elements x_k is None if the k-th parameter (starting
    from the most recent and ignoring let-definitions) is not contributing 
    or is Some u_k if its level is u_k and is contributing. *)
-let param_ccls params =
-  let fold acc = function (_, None, p) -> 
+let param_ccls paramsctxt =
+  let fold acc = function
+    | (LocalAssum (_, p)) ->
       (let c = strip_prod_assum p in
       match kind_of_term c with
         | Sort (Type u) -> Univ.Universe.level u
         | _ -> None) :: acc
-    | _ -> acc 
+    | LocalDef _ -> acc
   in
-  List.fold_left fold [] params
+  List.fold_left fold [] paramsctxt
 
 (* Type-check an inductive definition. Does not check positivity
    conditions. *)
@@ -203,7 +221,7 @@ let typecheck_inductive env mie =
   mind_check_names mie;
   (* Params are typed-checked here *)
   let env' = push_context mie.mind_entry_universes env in
-  let (env_params, params) = infer_local_decls env' mie.mind_entry_params in
+  let (env_params,paramsctxt) = infer_local_decls env' mie.mind_entry_params in
   (* We first type arity of each inductive definition *)
   (* This allows building the environment of arities and to share *)
   (* the set of constraints *)
@@ -242,26 +260,26 @@ let typecheck_inductive env mie =
 	    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 params in
+	 let full_arity = it_mkProd_or_LetIn arity paramsctxt in
 	 let id = ind.mind_entry_typename in
 	 let env_ar' =
-           push_rel (Name id, None, full_arity) env_ar in
+           push_rel (LocalAssum (Name id, full_arity)) env_ar in
              (* (add_constraints cst2 env_ar) in *)
-	   (env_ar', (id,full_arity,sign @ params,expltype,deflev,inflev)::l))
+	   (env_ar', (id,full_arity,sign @ paramsctxt,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 env_arities in
+  let env_ar_par = push_rel_context paramsctxt env_arities in
 
   (* Now, we type the constructors (without params) *)
   let inds =
     List.fold_right2
       (fun ind arity_data inds ->
 	 let (lc',cstrs_univ) =
-	   infer_constructor_packet env_ar_par params ind.mind_entry_lc in
+	   infer_constructor_packet env_ar_par paramsctxt ind.mind_entry_lc in
 	 let consnames = ind.mind_entry_consnames in
 	 let ind' = (arity_data,consnames,lc',cstrs_univ) in
 	   ind'::inds)
@@ -284,7 +302,7 @@ let typecheck_inductive env mie =
       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)
+	  type_in_type env || (UGraph.check_leq (universes env') infu defu)
 	in
 	let _ =
 	  (** Impredicative sort, always allow *)
@@ -310,14 +328,14 @@ let typecheck_inductive env mie =
 	    (* 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
+	    let b = type_in_type env || UGraph.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)
+		TemplateArity (param_ccls paramsctxt, infu)
 	  | _ (* Not an explicit occurrence of Type *) ->
 	    full_polymorphic ()
       in
@@ -327,7 +345,7 @@ let typecheck_inductive env mie =
       in
 	(id,cn,lc,(sign,arity)))
     inds
-  in (env_arities, env_ar_par, params, inds)
+  in (env_arities, env_ar_par, paramsctxt, inds)
 
 (************************************************************************)
 (************************************************************************)
@@ -336,7 +354,7 @@ let typecheck_inductive env mie =
 type ill_formed_ind =
   | LocalNonPos of int
   | LocalNotEnoughArgs of int
-  | LocalNotConstructor of rel_context * constr list
+  | LocalNotConstructor of Context.Rel.t * int
   | LocalNonPar of int * int * int
 
 exception IllFormedInd of ill_formed_ind
@@ -347,22 +365,22 @@ exception IllFormedInd of ill_formed_ind
 
 let mind_extract_params = decompose_prod_n_assum
 
-let explain_ind_err id ntyp env nbpar c err =
-  let (lpar,c') = mind_extract_params nbpar c in
+let explain_ind_err id ntyp env nparamsctxt c err =
+  let (lparams,c') = mind_extract_params nparamsctxt c in
   match err with
     | LocalNonPos kt ->
-	raise (InductiveError (NonPos (env,c',mkRel (kt+nbpar))))
+	raise (InductiveError (NonPos (env,c',mkRel (kt+nparamsctxt))))
     | LocalNotEnoughArgs kt ->
 	raise (InductiveError
-		 (NotEnoughArgs (env,c',mkRel (kt+nbpar))))
-    | LocalNotConstructor (paramsctxt,args)->
-        let nparams = rel_context_nhyps paramsctxt in
+		 (NotEnoughArgs (env,c',mkRel (kt+nparamsctxt))))
+    | LocalNotConstructor (paramsctxt,nargs)->
+        let nparams = Context.Rel.nhyps paramsctxt in
 	raise (InductiveError
-		 (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nparams,
-                                  List.length args - nparams)))
+		 (NotConstructor (env,id,c',mkRel (ntyp+nparamsctxt),
+                                  nparams,nargs)))
     | LocalNonPar (n,i,l) ->
 	raise (InductiveError
-		 (NonPar (env,c',n,mkRel i, mkRel (l+nbpar))))
+		 (NonPar (env,c',n,mkRel i,mkRel (l+nparamsctxt))))
 
 let failwith_non_pos n ntypes c =
   for k = n to n + ntypes - 1 do
@@ -378,43 +396,50 @@ let failwith_non_pos_list n ntypes l =
   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 =
-  let nparams = rel_context_nhyps hyps in
-  let largs = Array.of_list largs in
-  if Array.length largs < nparams then
-    raise (IllFormedInd (LocalNotEnoughArgs l));
-  let (lpar,largs') = Array.chop nparams largs in
-  let nhyps = List.length hyps in
-  let rec check k index = function
+(* [n] is the index of the last inductive type in [env] *)
+let check_correct_par (env,n,ntypes,_) paramdecls ind_index args =
+  let nparams = Context.Rel.nhyps paramdecls in
+  let args = Array.of_list args in
+  if Array.length args < nparams then
+    raise (IllFormedInd (LocalNotEnoughArgs ind_index));
+  let (params,realargs) = Array.chop nparams args in
+  let nparamdecls = List.length paramdecls in
+  let rec check param_index paramdecl_index = function
     | [] -> ()
-    | (_,Some _,_)::hyps -> check k (index+1) hyps
-    | _::hyps ->
-        match kind_of_term (whd_betadeltaiota env lpar.(k)) with
-	  | Rel w when Int.equal w index -> check (k-1) (index+1) hyps
-	  | _ -> raise (IllFormedInd (LocalNonPar (k+1, index-n+nhyps+1, l)))
-  in check (nparams-1) (n-nhyps) hyps;
-  if not (Array.for_all (noccur_between n ntypes) largs') then
-    failwith_non_pos_vect n ntypes largs'
-
-(* Computes the maximum number of recursive parameters :
-    the first parameters which are constant in recursive arguments
-    n is the current depth, nmr is the maximum number of possible
-    recursive parameters *)
-
-let compute_rec_par (env,n,_,_) hyps nmr largs =
+    | LocalDef _ :: paramdecls ->
+      check param_index (paramdecl_index+1) paramdecls
+    | _::paramdecls ->
+        match kind_of_term (whd_all env params.(param_index)) with
+	  | Rel w when Int.equal w paramdecl_index ->
+            check (param_index-1) (paramdecl_index+1) paramdecls
+	  | _ ->
+            let paramdecl_index_in_env = paramdecl_index-n+nparamdecls+1 in
+            let err =
+              LocalNonPar (param_index+1, paramdecl_index_in_env, ind_index) in
+            raise (IllFormedInd err)
+  in check (nparams-1) (n-nparamdecls) paramdecls;
+  if not (Array.for_all (noccur_between n ntypes) realargs) then
+    failwith_non_pos_vect n ntypes realargs
+
+(* Computes the maximum number of recursive parameters:
+   the first parameters which are constant in recursive arguments
+   [n] is the current depth, [nmr] is the maximum number of possible
+   recursive parameters *)
+
+let compute_rec_par (env,n,_,_) paramsctxt nmr largs =
 if Int.equal nmr 0 then 0 else
-(* start from 0, hyps will be in reverse order *)
+(* start from 0, params will be in reverse order *)
   let (lpar,_) = List.chop nmr largs in
   let rec find k index =
       function
 	  ([],_) -> nmr
-	| (_,[]) -> assert false (* |hyps|>=nmr *)
-	| (lp,(_,Some _,_)::hyps) -> find k (index-1) (lp,hyps)
-	| (p::lp,_::hyps) ->
-       ( match kind_of_term (whd_betadeltaiota env p) with
-	  | Rel w when Int.equal w index -> find (k+1) (index-1) (lp,hyps)
+	| (_,[]) -> assert false (* |paramsctxt|>=nmr *)
+	| (lp, LocalDef _ :: paramsctxt) -> find k (index-1) (lp,paramsctxt)
+	| (p::lp,_::paramsctxt) ->
+       ( match kind_of_term (whd_all env p) with
+	  | Rel w when Int.equal w index -> find (k+1) (index-1) (lp,paramsctxt)
           | _ -> k)
-  in find 0 (n-1) (lpar,List.rev hyps)
+  in find 0 (n-1) (lpar,List.rev paramsctxt)
 
 (* [env] is the typing environment
    [n] is the dB of the last inductive type
@@ -423,15 +448,15 @@ if Int.equal nmr 0 then 0 else
    [lra] is the list of recursive tree of each variable
  *)
 let ienv_push_var (env, n, ntypes, lra) (x,a,ra) =
- (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra)
+  (push_rel (LocalAssum (x,a)) env, n+1, ntypes, (Norec,ra)::lra)
 
-let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lpar) =
+let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lrecparams) =
   let auxntyp = 1 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 ty lpar) env in
+    let decl = LocalAssum (Anonymous, hnf_prod_applist env ty lrecparams) in
+    push_rel decl 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
@@ -441,7 +466,7 @@ let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lpar) =
 
 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
+    let c' = whd_all env c in
     match kind_of_term c' with
 	Prod(na,a,b) ->
 	  let ienv' = ienv_push_var ienv (na,a,mk_norec) in
@@ -451,75 +476,115 @@ let rec ienv_decompose_prod (env,_,_,_ as ienv) n c =
 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
-   of recursive arguments *)
-let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcnames indlc =
-  let lparams = rel_context_length hyps in
-  let nmr = rel_context_nhyps hyps in
-  (* Checking the (strict) positivity of a constructor argument type [c] *)
+(** [check_positivity_one ienv paramsctxt (mind,i) nnonrecargs lcnames indlc]
+    checks the positivity of the [i]-th member of the mutually
+    inductive definition [mind]. It returns an [Rtree.t] which
+    represents the position of the recursive calls of inductive in [i]
+    for use by the guard condition (terms at these positions are
+    considered sub-terms) as well as the number of of non-uniform
+    arguments (used to generate induction schemes, so a priori less
+    relevant to the kernel).
+
+    If [chkpos] is [false] then positivity is assumed, and
+    [check_positivity_one] computes the subterms occurrences in a
+    best-effort fashion. *)
+let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt (_,i as ind) nnonrecargs lcnames indlc =
+  let nparamsctxt = Context.Rel.length paramsctxt in
+  let nmr = Context.Rel.nhyps paramsctxt in
+  (** Positivity of one argument [c] of a constructor (i.e. the
+      constructor [cn] has a type of the shape [… -> c … -> P], where,
+      more generally, the arrows may be dependent). *)
   let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c =
-    let x,largs = decompose_app (whd_betadeltaiota env c) in
+    let x,largs = decompose_app (whd_all env c) in
       match kind_of_term x with
 	| Prod (na,b,d) ->
 	    let () = assert (List.is_empty largs) in
+            (** If one of the inductives of the mutually inductive
+                block occurs in the left-hand side of a product, then
+                such an occurrence is a non-strictly-positive
+                recursive call. Occurrences in the right-hand side of
+                the product must be strictly positive.*)
             (match weaker_noccur_between env n ntypes b with
-		None -> failwith_non_pos_list n ntypes [b]
+	      | None when chkpos ->
+                  failwith_non_pos_list n ntypes [b]
+              | None ->
+                  check_pos (ienv_push_var ienv (na, b, mk_norec)) nmr d
               | Some b ->
-	          check_pos (ienv_push_var ienv (na, b, mk_norec)) nmr d)
+                  check_pos (ienv_push_var ienv (na, b, mk_norec)) nmr d)
 	| Rel k ->
             (try let (ra,rarg) = List.nth ra_env (k-1) in
-            let largs = List.map (whd_betadeltaiota env) largs in
+            let largs = List.map (whd_all env) largs in
 	    let nmr1 =
 	      (match ra with
-                  Mrec _ -> compute_rec_par ienv hyps nmr largs
+                  Mrec _ -> compute_rec_par ienv paramsctxt nmr largs
 		|  _ -> nmr)
 	    in
-	      if not (List.for_all (noccur_between n ntypes) largs)
+              (** The case where one of the inductives of the mutually
+                  inductive block occurs as an argument of another is not
+                  known to be safe. So Coq rejects it. *)
+	      if chkpos &&
+                 not (List.for_all (noccur_between n ntypes) largs)
 	      then failwith_non_pos_list n ntypes largs
 	      else (nmr1,rarg)
               with Failure _ | Invalid_argument _ -> (nmr,mk_norec))
 	| Ind ind_kn ->
-            (* If the inductive type being defined appears in a
-               parameter, then we have a nested indtype *)
+            (** If one of the inductives of the mutually inductive
+                block being defined appears in a parameter, then we
+                have a nested inductive type. The positivity is then
+                discharged to the [check_positive_nested] function. *)
             if List.for_all (noccur_between n ntypes) largs then (nmr,mk_norec)
             else check_positive_nested ienv nmr (ind_kn, largs)
 	| err ->
-	    if noccur_between n ntypes x &&
-              List.for_all (noccur_between n ntypes) largs
+            (** If an inductive of the mutually inductive block
+                appears in any other way, then the positivy check gives
+                up. *)
+	    if not chkpos ||
+              (noccur_between n ntypes x &&
+               List.for_all (noccur_between n ntypes) largs)
 	    then (nmr,mk_norec)
 	    else failwith_non_pos_list n ntypes (x::largs)
 
+  (** [check_positive_nested] handles the case of nested inductive
+      calls, that is, when an inductive types from the mutually
+      inductive block is called as an argument of an inductive types
+      (for the moment, this inductive type must be a previously
+      defined types, not one of the types of the mutually inductive
+      block being defined). *)
   (* accesses to the environment are not factorised, but is it worth? *)
   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
+    let auxnrecpar = mib.mind_nparams_rec in
+    let auxnnonrecpar = mib.mind_nparams - auxnrecpar in
+    let (auxrecparams,auxnonrecargs) =
+      try List.chop auxnrecpar largs
       with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in
-      (* If the inductive appears in the args (non params) then the
-	 definition is not positive. *)
 
-      if not (List.for_all (noccur_between n ntypes) auxlargs) then
-	failwith_non_pos_list n ntypes auxlargs;
-      (* We do not deal with imbricated mutual inductive types *)
+      (** Inductives of the inductive block being defined are only
+          allowed to appear nested in the parameters of another inductive
+          type. Not in the proper indices. *)
+      if chkpos && not (List.for_all (noccur_between n ntypes) auxnonrecargs) then
+	failwith_non_pos_list n ntypes auxnonrecargs;
+      (* Nested mutual inductive types are not supported *)
       let auxntyp = mib.mind_ntypes in
 	if not (Int.equal auxntyp 1) then raise (IllFormedInd (LocalNonPos n));
 	(* The nested inductive type with parameters removed *)
-	let auxlcvect = abstract_mind_lc auxntyp auxnpar mip.mind_nf_lc in
+	let auxlcvect = abstract_mind_lc auxntyp auxnrecpar 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,u),lpar) in
+	let (env',_,_,_ as ienv') = ienv_push_inductive ienv ((mi,u),auxrecparams) in
 	  (* Parameters expressed in env' *)
-	let lpar' = List.map (lift auxntyp) lpar in
+	let auxrecparams' = List.map (lift auxntyp) auxrecparams in
 	let irecargs_nmr =
-	  (* fails if the inductive type occurs non positively *)
-	  (* with recursive parameters substituted *)
+	  (** Checks that the "nesting" inductive type is covariant in
+	      the relevant parameters. In other words, that the
+	      (nested) parameters which are instantiated with
+	      inductives of the mutually inductive block occur
+	      positively in the types of the nested constructors. *)
 	  Array.map
 	    (function c ->
-	      let c' = hnf_prod_applist env' c lpar' in
+	      let c' = hnf_prod_applist env' c auxrecparams' in
 	      (* skip non-recursive parameters *)
-	      let (ienv',c') = ienv_decompose_prod ienv' nonrecpar c' in
+	      let (ienv',c') = ienv_decompose_prod ienv' auxnnonrecpar c' in
 		check_constructors ienv' false nmr c')
 	    auxlcvect
 	in
@@ -528,17 +593,23 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
 	in
 	  (nmr',(Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0))
 
-  (* check the inductive types occur positively in the products of C, if
-     check_head=true, also check the head corresponds to a constructor of
-     the ith type *)
-
+  (** [check_constructors ienv check_head nmr c] checks the positivity
+      condition in the type [c] of a constructor (i.e. that recursive
+      calls to the inductives of the mutually inductive definition
+      appear strictly positively in each of the arguments of the
+      constructor, see also [check_pos]). If [check_head] is [true],
+      then the type of the fully applied constructor (the "head" of
+      the type [c]) is checked to be the right (properly applied)
+      inductive type. *)
   and check_constructors ienv check_head nmr c =
     let rec check_constr_rec (env,n,ntypes,ra_env as ienv) nmr lrec c =
-      let x,largs = decompose_app (whd_betadeltaiota env c) in
+      let x,largs = decompose_app (whd_all env c) in
 	match kind_of_term x with
 
           | Prod (na,b,d) ->
 	      let () = assert (List.is_empty largs) in
+	      if not recursive && not (noccur_between n ntypes b) then
+	        raise (InductiveError BadEntry);
               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
@@ -547,11 +618,12 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
               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(hyps,largs)))
+                  check_correct_par ienv paramsctxt (ntypes - i) largs
+                | _ -> raise (IllFormedInd (LocalNotConstructor(paramsctxt,nnonrecargs)))
                 end
               else
-                if not (List.for_all (noccur_between n ntypes) largs)
+                if chkpos &&
+                   not (List.for_all (noccur_between n ntypes) largs)
                 then failwith_non_pos_list n ntypes largs
             in
             (nmr, List.rev lrec)
@@ -560,29 +632,36 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
   let irecargs_nmr =
     Array.map2
       (fun id c ->
-        let _,rawc = mind_extract_params lparams c in
+        let _,rawc = mind_extract_params nparamsctxt c in
           try
 	    check_constructors ienv true nmr rawc
           with IllFormedInd err ->
-	    explain_ind_err id (ntypes-i) env lparams c err)
+	    explain_ind_err id (ntypes-i) env nparamsctxt c err)
       (Array.of_list lcnames) indlc
   in
   let irecargs = Array.map snd irecargs_nmr
   and nmr' = array_min nmr irecargs_nmr
   in (nmr', mk_paths (Mrec ind) irecargs)
 
-let check_positivity kn env_ar params inds =
+(** [check_positivity ~chkpos kn env_ar paramsctxt inds] checks that the mutually
+    inductive block [inds] is strictly positive.
+
+    If [chkpos] is [false] then positivity is assumed, and
+    [check_positivity_one] computes the subterms occurrences in a
+    best-effort fashion. *)
+let check_positivity ~chkpos kn env_ar_par paramsctxt finite inds =
   let ntypes = Array.length inds in
+  let recursive = finite != Decl_kinds.BiFinite in
   let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) 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 ra_env_ar = Array.rev_to_list rc in
+  let nparamsctxt = Context.Rel.length paramsctxt in
+  let nmr = Context.Rel.nhyps paramsctxt in
   let check_one i (_,lcnames,lc,(sign,_)) =
-    let ra_env =
-      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
+    let ra_env_ar_par =
+      List.init nparamsctxt (fun _ -> (Norec,mk_norec)) @ ra_env_ar in
+    let ienv = (env_ar_par, 1+nparamsctxt, ntypes, ra_env_ar_par) in
+    let nnonrecargs = Context.Rel.nhyps sign - nmr in
+    check_positivity_one ~chkpos recursive ienv paramsctxt (kn,i) nnonrecargs lcnames lc
   in
   let irecargs_nmr = Array.mapi check_one inds in
   let irecargs = Array.map snd irecargs_nmr
@@ -639,6 +718,7 @@ let used_section_variables env inds =
   keep_hyps env ids
 
 let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i))
+let rel_list n m = Array.to_list (rel_vect n m)
 
 exception UndefinableExpansion
 
@@ -653,23 +733,21 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params
       that typechecking projections requires just a substitution and not
       matching with a parameter context. *)
   let indty, paramsletsubst =
-    let _, _, subst, inst =
-      List.fold_right
-	(fun (na, b, t) (i, j, subst, inst) ->
-	 match b with
-	 | None -> (i-1, j-1, mkRel i :: subst, mkRel j :: inst)
-	 | Some b -> (i, j-1, substl subst b :: subst, inst))
-	paramslet (nparamargs, List.length paramslet, [], [])
-    in
+    (* [ty] = [Ind inst] is typed in context [params] *)
+    let inst = Context.Rel.to_extended_vect 0 paramslet in
+    let ty = mkApp (mkIndU indu, inst) in
+    (* [Ind inst] is typed in context [params-wo-let] *)
+    let inst' = rel_list 0 nparamargs in
+    (* {params-wo-let |- subst:params] *)
+    let subst = subst_of_rel_context_instance paramslet inst' in
+    (* {params-wo-let, x:Ind inst' |- subst':(params,x:Ind inst)] *)
     let subst = (* For the record parameter: *)
-      mkRel 1 :: List.map (lift 1) subst
-    in
-    let ty = mkApp (mkIndU indu, CArray.rev_of_list inst) in
+      mkRel 1 :: List.map (lift 1) subst in
       ty, subst
   in
   let ci = 
     let print_info =
-      { ind_tags = []; cstr_tags = [|rel_context_tags ctx|]; style = LetStyle } in
+      { ind_tags = []; cstr_tags = [|Context.Rel.to_tags ctx|]; style = LetStyle } in
       { ci_ind     = ind;
 	ci_npar    = nparamargs;
 	ci_cstr_ndecls = mind_consnrealdecls;
@@ -687,9 +765,9 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params
     let body = mkCase (ci, p, mkRel 1, [|lift 1 branch|]) in
       it_mkLambda_or_LetIn (mkLambda (x,indty,body)) params
   in
-  let projections (na, b, t) (i, j, kns, pbs, subst, letsubst) =
-    match b with
-    | Some c ->
+  let projections decl (i, j, kns, pbs, subst, letsubst) =
+    match decl with
+    | LocalDef (na,c,t) ->
         (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)]
            to [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] *)
         let c = liftn 1 j c in
@@ -707,7 +785,7 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params
            to [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj+1)] *)
         let letsubst = c2 :: letsubst in
         (i, j+1, kns, pbs, subst, letsubst)
-    | None ->
+    | LocalAssum (na,t) ->
       match na with
       | Name id ->
 	let kn = Constant.make1 (KerName.make mp dp (Label.of_id id)) in
@@ -738,14 +816,14 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params
     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 build_inductive env p prv ctx env_ar paramsctxt 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 nparamargs = rel_context_nhyps params in
-  let nparamdecls = rel_context_length params in
+  let nparamargs = Context.Rel.nhyps paramsctxt in
+  let nparamsctxt = Context.Rel.length paramsctxt in
   let subst, ctx = Univ.abstract_universes p ctx in
-  let params = Vars.subst_univs_level_context subst params in
+  let paramsctxt = Vars.subst_univs_level_context subst paramsctxt in
   let env_ar = 
     let ctx = Environ.rel_context env_ar in 
     let ctx' = Vars.subst_univs_level_context subst ctx in
@@ -758,10 +836,10 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re
     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 consnrealdecls =
-      Array.map (fun (d,_) -> rel_context_length d - rel_context_length params)
+      Array.map (fun (d,_) -> Context.Rel.length d - nparamsctxt)
 	splayed_lc in
     let consnrealargs =
-      Array.map (fun (d,_) -> rel_context_nhyps d - rel_context_nhyps params)
+      Array.map (fun (d,_) -> Context.Rel.nhyps d - nparamargs)
 	splayed_lc in
     (* Elimination sorts *)
     let arkind,kelim = 
@@ -794,8 +872,8 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re
       { mind_typename = id;
 	mind_arity = arkind;
 	mind_arity_ctxt = Vars.subst_univs_level_context subst ar_sign;
-	mind_nrealargs = rel_context_nhyps ar_sign - nparamargs;
-	mind_nrealdecls = rel_context_length ar_sign - nparamdecls;
+	mind_nrealargs = Context.Rel.nhyps ar_sign - nparamargs;
+	mind_nrealdecls = Context.Rel.length ar_sign - nparamsctxt;
 	mind_kelim = kelim;
 	mind_consnames = Array.of_list cnames;
 	mind_consnrealdecls = consnrealdecls;
@@ -808,10 +886,11 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re
 	mind_reloc_tbl = rtbl;
       } in
   let packets = Array.map2 build_one_packet inds recargs in
-  let pkt = packets.(0) 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
+    | 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 = 
@@ -824,7 +903,7 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re
 	(try 
 	   let fields, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in
 	   let kns, projs = 
-	     compute_projections indsp pkt.mind_typename rid nparamargs params
+	     compute_projections indsp pkt.mind_typename rid nparamargs paramsctxt
 	       pkt.mind_consnrealdecls pkt.mind_consnrealargs paramslet fields
 	   in Some (Some (rid, kns, projs))
 	 with UndefinableExpansion -> Some None)
@@ -838,11 +917,12 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re
       mind_hyps = hyps;
       mind_nparams = nparamargs;
       mind_nparams_rec = nmr;
-      mind_params_ctxt = params;
+      mind_params_ctxt = paramsctxt;
       mind_packets = packets;
       mind_polymorphic = p;
       mind_universes = ctx;
       mind_private = prv;
+      mind_typing_flags = Environ.typing_flags env;
     }
 
 (************************************************************************)
@@ -850,11 +930,12 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re
 
 let check_inductive env kn mie =
   (* First type-check the inductive definition *)
-  let (env_ar, env_ar_par, params, inds) = typecheck_inductive env mie in
+  let (env_ar, env_ar_par, paramsctxt, inds) = typecheck_inductive env mie in
   (* Then check positivity conditions *)
-  let (nmr,recargs) = check_positivity kn env_ar_par params inds in
+  let chkpos = (Environ.typing_flags env).check_guarded in
+  let (nmr,recargs) = check_positivity ~chkpos kn env_ar_par paramsctxt mie.mind_entry_finite inds in
   (* Build the inductive packets *)
     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
+      env_ar paramsctxt kn mie.mind_entry_record mie.mind_entry_finite
       inds nmr recargs
diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli
index a7bf8fab..5b461539 100644
--- a/kernel/indtypes.mli
+++ b/kernel/indtypes.mli
@@ -42,6 +42,6 @@ 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 -> Context.rel_context -> 
+  int -> Context.Rel.t -> int array -> int array -> 
+  Context.Rel.t -> Context.Rel.t -> 
   (constant array * projection_body array)
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
index 80dc6904..3c4c2796 100644
--- a/kernel/inductive.ml
+++ b/kernel/inductive.ml
@@ -6,18 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Univ
 open Term
 open Vars
-open Context
 open Declarations
 open Declareops
 open Environ
 open Reduction
 open Type_errors
+open Context.Rel.Declaration
 
 type mind_specif = mutual_inductive_body * one_inductive_body
 
@@ -29,20 +29,20 @@ let lookup_mind_specif env (kn,tyi) =
   (mib, mib.mind_packets.(tyi))
 
 let find_rectype env c =
-  let (t, l) = decompose_app (whd_betadeltaiota env c) in
+  let (t, l) = decompose_app (whd_all env c) in
   match kind_of_term t with
   | Ind ind -> (ind, l)
   | _ -> raise Not_found
 
 let find_inductive env c =
-  let (t, l) = decompose_app (whd_betadeltaiota env c) in
+  let (t, l) = decompose_app (whd_all env c) in
   match kind_of_term t with
     | Ind ind
         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
+  let (t, l) = decompose_app (whd_all env c) in
   match kind_of_term t with
     | Ind ind
         when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite == Decl_kinds.CoFinite -> (ind, l)
@@ -77,11 +77,11 @@ let instantiate_params full t u args sign =
   let fail () =
     anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch") in
   let (rem_args, subs, ty) =
-    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)
-          | (Some b,_,LetIn(_,_,_,t))    ->
+    Context.Rel.fold_outside
+      (fun decl (largs,subs,ty) ->
+        match (decl, largs, kind_of_term ty) with
+          | (LocalAssum _, a::args, Prod(_,_,t)) -> (args, a::subs, t)
+          | (LocalDef (_,b,_), _, LetIn(_,_,_,t))    ->
 	     (largs, (substl subs (subst_instance_constr u b))::subs, t)
 	  | (_,[],_)                -> if full then fail() else ([], subs, ty)
 	  | _                       -> fail ())
@@ -151,9 +151,9 @@ let remember_subst u subst =
 
 (* Bind expected levels of parameters to actual levels *)
 (* Propagate the new levels in the signature *)
-let rec make_subst env =
+let make_subst env =
   let rec make subst = function
-    | (_,Some _,_)::sign, exp, args ->
+    | LocalDef _ :: sign, exp, args ->
         make subst (sign, exp, args)
     | d::sign, None::exp, args ->
         let args = match args with _::args -> args | [] -> [] in
@@ -166,7 +166,7 @@ let rec make_subst env =
         (* a useless extra constraint *)
         let s = sort_as_univ (snd (dest_arity env (Lazy.force a))) in
           make (cons_subst u s subst) (sign, exp, args)
-    | (na,None,t)::sign, Some u::exp, [] ->
+    | LocalAssum (na,t) :: sign, Some u::exp, [] ->
         (* No more argument here: we add the remaining universes to the *)
         (* substitution (when [u] is distinct from all other universes in the *)
         (* template, it is identity substitution  otherwise (ie. when u is *)
@@ -270,18 +270,6 @@ let type_of_constructors (ind,u) (mib,mip) =
 
 (* Type of case predicates *)
 
-let local_rels ctxt =
-  let (rels,_) =
-    Context.fold_rel_context_reverse
-      (fun (rels,n) (_,copt,_) ->
-        match copt with
-            None   -> (mkRel n :: rels, n+1)
-          | Some _ -> (rels, n+1))
-      ~init:([],1)
-      ctxt
-  in
-  rels
-
 (* Get type of inductive, with parameters instantiated *)
 
 let inductive_sort_family mip =
@@ -304,20 +292,12 @@ let is_primitive_record (mib,_) =
   | 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
-    | (_,Some _,_) :: hyps -> reln l (p+1) hyps
-    | [] -> l
-  in
-  reln [] 1 hyps
-
 let build_dependent_inductive ind (_,mip) params =
   let realargs,_ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in
   applist
     (mkIndU ind,
        List.map (lift mip.mind_nrealdecls) params
-       @ extended_rel_list 0 realargs)
+       @ Context.Rel.to_extended_list 0 realargs)
 
 (* This exception is local *)
 exception LocalArity of (sorts_family * sorts_family * arity_error) option
@@ -333,17 +313,17 @@ let check_allowed_sort ksort specif =
 let is_correct_arity env c pj ind specif params =
   let arsign,_ = get_instantiated_arity ind specif params in
   let rec srec env pt ar =
-    let pt' = whd_betadeltaiota env pt in
+    let pt' = whd_all env pt in
     match kind_of_term pt', ar with
-      | Prod (na1,a1,t), (_,None,a1')::ar' ->
+      | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' ->
           let () =
             try conv env a1 a1'
             with NotConvertible -> raise (LocalArity None) in
-          srec (push_rel (na1,None,a1) env) t ar' 
+          srec (push_rel (LocalAssum (na1,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
-	 let ksort = match kind_of_term (whd_betadeltaiota env' a2) with
+	 let env' = push_rel (LocalAssum (na1,a1)) env in
+	 let ksort = match kind_of_term (whd_all env' a2) with
 	 | Sort s -> family_of_sort s
 	 | _ -> raise (LocalArity None) in
 	 let dep_ind = build_dependent_inductive ind specif params in
@@ -351,7 +331,7 @@ let is_correct_arity env c pj ind specif params =
            try conv env a1 dep_ind
            with NotConvertible -> raise (LocalArity None) in
 	   check_allowed_sort ksort specif
-      | _, (_,Some _,_ as d)::ar' ->
+      | _, (LocalDef _ as d)::ar' ->
 	  srec (push_rel d env) (lift 1 pt') ar'
       | _ ->
 	  raise (LocalArity None)
@@ -369,22 +349,22 @@ let is_correct_arity env c pj ind specif params =
 let build_branches_type (ind,u) (_,mip as specif) params p =
   let build_one_branch i cty =
     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 (cstrsign,ccl) = decompose_prod_assum typi in
+    let nargs = Context.Rel.length cstrsign in
     let (_,allargs) = decompose_app ccl 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 (mkConstructU (cstr,u),lparams@(local_rels args)) in
+      let dep_cstr = applist (mkConstructU (cstr,u),lparams@(Context.Rel.to_extended_list 0 cstrsign)) in
       vargs @ [dep_cstr] in
-    let base = betazeta_appvect mip.mind_nrealdecls (lift nargs p) (Array.of_list cargs) in
-    it_mkProd_or_LetIn base args in
+    let base = lambda_appvect_assum (mip.mind_nrealdecls+1) (lift nargs p) (Array.of_list cargs) in
+    it_mkProd_or_LetIn base cstrsign in
   Array.mapi build_one_branch mip.mind_nf_lc
 
 (* [p] is the predicate, [c] is the match object, [realargs] is the
    list of real args of the inductive type *)
 let build_case_type env n p c realargs =
-  whd_betaiota env (betazeta_appvect (n+1) p (Array.of_list (realargs@[c])))
+  whd_betaiota env (lambda_appvect_assum (n+1) p (Array.of_list (realargs@[c])))
 
 let type_case_branches env (pind,largs) pj c =
   let specif = lookup_mind_specif env (fst pind) in
@@ -500,10 +480,10 @@ type guard_env =
 let make_renv env recarg tree =
   { env = env;
     rel_min = recarg+2; (* recarg = 0 ==> Rel 1 -> recarg; Rel 2 -> fix *)
-    genv = [Lazy.lazy_from_val(Subterm(Large,tree))] }
+    genv = [Lazy.from_val(Subterm(Large,tree))] }
 
 let push_var renv (x,ty,spec) =
-  { env = push_rel (x,None,ty) renv.env;
+  { env = push_rel (LocalAssum (x,ty)) renv.env;
     rel_min = renv.rel_min+1;
     genv = spec:: renv.genv }
 
@@ -519,7 +499,7 @@ let subterm_var p renv =
   with Failure _ | Invalid_argument _ -> Not_subterm
 
 let push_ctxt_renv renv ctxt =
-  let n = rel_context_length ctxt in
+  let n = Context.Rel.length ctxt in
   { env = push_rel_context ctxt renv.env;
     rel_min = renv.rel_min+n;
     genv = iterate (fun ge -> lazy Not_subterm::ge) n renv.genv }
@@ -583,20 +563,20 @@ let check_inductive_codomain env p =
   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
+  let i,l' = decompose_app (whd_all 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)
+  (push_rel (LocalAssum (x,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
+    let decl = LocalAssum (Anonymous, hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) in
+    push_rel decl 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
@@ -606,7 +586,7 @@ let ienv_push_inductive (env, ra_env) ((mind,u),lpar) =
 
 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
+   let c' = whd_all env c in
    match kind_of_term c' with
    Prod(na,a,b) ->
      let ienv' = ienv_push_var ienv (na,a,mk_norec) in
@@ -638,7 +618,7 @@ close to check_positive in indtypes.ml, but does no positivity check and does no
 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
+    let x,largs = decompose_app (whd_all env c) in
     match kind_of_term x with
     | Prod (na,b,d) ->
        assert (List.is_empty largs);
@@ -697,7 +677,7 @@ let get_recargs_approx env tree ind args =
 
   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
+      let x,largs = decompose_app (whd_all env c) in
 	match kind_of_term x with
 
           | Prod (na,b,d) ->
@@ -721,12 +701,12 @@ let restrict_spec env spec p =
   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
+  if noccur_with_meta 1 (Context.Rel.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
+  let i,args = decompose_app (whd_all env s) in
   match kind_of_term i with
   | Ind i ->
      begin match spec with
@@ -747,7 +727,7 @@ let restrict_spec env spec p =
 
 let rec subterm_specif renv stack t =
   (* maybe reduction is not always necessary! *)
-  let f,l = decompose_app (whd_betadeltaiota renv.env t) in
+  let f,l = decompose_app (whd_all renv.env t) in
     match kind_of_term f with
     | Rel k -> subterm_var k renv
     | Case (ci,p,c,lbr) ->
@@ -814,7 +794,15 @@ let rec subterm_specif renv stack t =
     | Proj (p, c) -> 
       let subt = subterm_specif renv stack c in
 	(match subt with
-	| Subterm (s, wf) -> Subterm (Strict, wf)
+	| Subterm (s, wf) ->
+	   (* We take the subterm specs of the constructor of the record *)
+	   let wf_args = (dest_subterms wf).(0) in
+	   (* We extract the tree of the projected argument *)
+	   let kn = Projection.constant p in
+	   let cb = lookup_constant kn renv.env in
+	   let pb = Option.get cb.const_proj in
+	   let n = pb.proj_arg in
+	   Subterm (Strict, List.nth wf_args n)
 	| Dead_code -> Dead_code
 	| Not_subterm -> Not_subterm)
 
@@ -829,7 +817,7 @@ and stack_element_specif = function
   |SArg x -> x
 
 and extract_stack renv a = function
-   | [] -> Lazy.lazy_from_val Not_subterm , []
+   | [] -> Lazy.from_val Not_subterm , []
    | h::t -> stack_element_specif h, t
 
 (* Check term c can be applied to one of the mutual fixpoints. *)
@@ -863,14 +851,14 @@ 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
+  if noccur_with_meta 1 (Context.Rel.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
+    let t = whd_all 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 d = LocalAssum (n,a) in
+      let ty, args = decompose_app (whd_all env a) in
       let elt = match kind_of_term ty with
       | Ind ind -> 
         let spec' = stack_element_specif elt in
@@ -926,10 +914,10 @@ let check_one_fix renv recpos trees def =
               end
             else
               begin
-                match pi2 (lookup_rel p renv.env) with
-                | None ->
+                match lookup_rel p renv.env with
+                | LocalAssum _ ->
                     List.iter (check_rec_call renv []) l
-                | Some c ->
+                | LocalDef (_,c,_) ->
                     try List.iter (check_rec_call renv []) l
                     with FixGuardError _ ->
                       check_rec_call renv stack (applist(lift p c,l))
@@ -1002,12 +990,17 @@ let check_one_fix renv recpos trees def =
         | (Ind _ | Construct _) ->
             List.iter (check_rec_call renv []) l
 
+	| Proj (p, c) ->
+           List.iter (check_rec_call renv []) l;
+           check_rec_call renv [] c
+
         | Var id ->
             begin
-              match pi2 (lookup_named id renv.env) with
-              | None ->
+              let open Context.Named.Declaration in
+              match lookup_named id renv.env with
+              | LocalAssum _ ->
                   List.iter (check_rec_call renv []) l
-              | Some c ->
+              | LocalDef (_,c,_) ->
                   try List.iter (check_rec_call renv []) l
                   with (FixGuardError _) -> 
 		    check_rec_call renv stack (applist(c,l))
@@ -1020,8 +1013,6 @@ let check_one_fix renv recpos trees def =
         | (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 Int.equal decr 0 then
@@ -1058,10 +1049,10 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
     (* check fi does not appear in the k+1 first abstractions,
        gives the type of the k+1-eme abstraction (must be an inductive)  *)
     let rec check_occur env n def =
-      match kind_of_term (whd_betadeltaiota env def) with
+      match kind_of_term (whd_all env def) with
         | Lambda (x,a,b) ->
 	    if noccur_with_meta n nbfix a then
-	      let env' = push_rel (x, None, a) env in
+	      let env' = push_rel (LocalAssum (x,a)) env in
               if Int.equal n (k + 1) then
                 (* get the inductive type of the fixpoint *)
                 let (mind, _) =
@@ -1079,20 +1070,24 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
 
 
 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) 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)
-  done
+  let flags = Environ.typing_flags env in
+  if flags.check_guarded then
+    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) 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)
+    done
+  else
+    ()
 
 (*
 let cfkey = Profile.declare_profile "check_fix";;
@@ -1108,10 +1103,10 @@ let anomaly_ill_typed () =
   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
+  let b = whd_all env c in
   match kind_of_term b with
     | Prod (x,a,b) ->
-	codomain_is_coind (push_rel (x, None, a) env) b
+	codomain_is_coind (push_rel (LocalAssum (x,a)) env) b
     | _ ->
 	(try find_coinductive env b
         with Not_found ->
@@ -1120,7 +1115,7 @@ let rec codomain_is_coind env c =
 let check_one_cofix env nbfix def deftype =
   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
+      let c,args = decompose_app (whd_all env t) in
       match kind_of_term c with
 	| Rel p when  n <= p && p < n+nbfix ->
 	    (* recursive call: must be guarded and no nested recursive
@@ -1152,7 +1147,7 @@ let check_one_cofix env nbfix def deftype =
 	| Lambda (x,a,b) ->
 	    let () = assert (List.is_empty args) in
             if noccur_with_meta n nbfix a then
-              let env' = push_rel (x, None, a) env in
+              let env' = push_rel (LocalAssum (x,a)) env in
               check_rec_call env' alreadygrd (n+1) tree vlra b
             else
 	      raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a))
@@ -1204,11 +1199,15 @@ let check_one_cofix env nbfix def deftype =
    satisfies the guarded condition *)
 
 let check_cofix env (bodynum,(names,types,bodies as recdef)) =
-  let nbfix = Array.length bodies in
-  for i = 0 to nbfix-1 do
-    let fixenv = push_rec_types recdef env in
-    try check_one_cofix fixenv nbfix bodies.(i) types.(i)
-    with CoFixGuardError (errenv,err) ->
-      error_ill_formed_rec_body errenv err names i
-	fixenv (judgment_of_fixpoint recdef)
-  done
+  let flags = Environ.typing_flags env in
+  if flags.check_guarded then
+    let nbfix = Array.length bodies in
+    for i = 0 to nbfix-1 do
+      let fixenv = push_rec_types recdef env in
+      try check_one_cofix fixenv nbfix bodies.(i) types.(i)
+      with CoFixGuardError (errenv,err) ->
+        error_ill_formed_rec_body errenv err names i
+	  fixenv (judgment_of_fixpoint recdef)
+    done
+  else
+    ()
diff --git a/kernel/inductive.mli b/kernel/inductive.mli
index b2f1e038..521ee3c7 100644
--- a/kernel/inductive.mli
+++ b/kernel/inductive.mli
@@ -8,7 +8,6 @@
 
 open Names
 open Term
-open Context
 open Univ
 open Declarations
 open Environ
@@ -35,7 +34,7 @@ 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 -> universe_instance -> constr list
 
-val inductive_paramdecls : mutual_inductive_body puniverses -> rel_context
+val inductive_paramdecls : mutual_inductive_body puniverses -> Context.Rel.t
 
 val instantiate_inductive_constraints : 
   mutual_inductive_body -> universe_instance -> constraints
@@ -86,7 +85,7 @@ val build_branches_type :
     constr list -> constr -> types array
 
 (** Return the arity of an inductive type *)
-val mind_arity : one_inductive_body -> rel_context * sorts_family
+val mind_arity : one_inductive_body -> Context.Rel.t * sorts_family
 
 val inductive_sort_family : one_inductive_body -> sorts_family
 
@@ -95,6 +94,9 @@ val inductive_sort_family : one_inductive_body -> sorts_family
 val check_case_info : env -> pinductive -> case_info -> unit
 
 (** {6 Guard conditions for fix and cofix-points. } *)
+
+(** When [chk] is false, the guard condition is not actually
+    checked. *)
 val check_fix : env -> fixpoint -> unit
 val check_cofix : env -> cofixpoint -> unit
 
@@ -111,8 +113,8 @@ exception SingletonInductiveBecomesProp of Id.t
 
 val max_inductive_sort : sorts array -> universe
 
-val instantiate_universes : env -> rel_context ->
-  template_arity -> constr Lazy.t array -> rel_context * sorts
+val instantiate_universes : env -> Context.Rel.t ->
+  template_arity -> constr Lazy.t array -> Context.Rel.t * sorts
 
 (** {6 Debug} *)
 
diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib
index 29fe887d..15f213ce 100644
--- a/kernel/kernel.mllib
+++ b/kernel/kernel.mllib
@@ -1,6 +1,7 @@
 Names
 Uint31
 Univ
+UGraph
 Esubst
 Sorts
 Evar
@@ -14,7 +15,6 @@ Copcodes
 Cemitcodes
 Nativevalues
 Primitives
-Nativeinstr
 Opaqueproof
 Declareops
 Retroknowledge
@@ -25,7 +25,7 @@ Nativelambda
 Nativecode
 Nativelib
 Environ
-Closure
+CClosure
 Reduction
 Nativeconv
 Type_errors
diff --git a/kernel/make-opcodes b/kernel/make-opcodes
index c8f573c6..e1371b3d 100644
--- a/kernel/make-opcodes
+++ b/kernel/make-opcodes
@@ -1,2 +1,3 @@
 $1=="enum" {n=0; next; }
-           {for (i = 1; i <= NF; i++) {printf("let op%s = %d\n", $i, n++);}}
+           {printf("(* THIS FILE IS GENERATED. DON'T EDIT. *)\n\n");
+           for (i = 1; i <= NF; i++) {printf("let op%s = %d\n", $i, n++);}}
diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml
index 4fc777c4..ff44f0f5 100644
--- a/kernel/mod_typing.ml
+++ b/kernel/mod_typing.ml
@@ -104,7 +104,7 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv =
 	  let csti = Univ.enforce_eq_instances cus newus cst in
 	  let csta = Univ.Constraint.union csti ccst in
 	  let env' = Environ.push_context ~strict:false (Univ.UContext.make (inst, csta)) env in
-	  let () = if not (Univ.check_constraints cst (Environ.universes env')) then
+	  let () = if not (UGraph.check_constraints cst (Environ.universes env')) then
 		     error_incorrect_with_constraint lab
 	  in
 	  let cst = match cb.const_body with
diff --git a/kernel/modops.ml b/kernel/modops.ml
index 6fe7e382..0f0056ed 100644
--- a/kernel/modops.ml
+++ b/kernel/modops.ml
@@ -264,7 +264,7 @@ let add_retroknowledge mp =
     |Retroknowledge.RKRegister (f, e) when (isConst e || isInd e) ->
       Environ.register env f e
     |_ ->
-      Errors.anomaly ~label:"Modops.add_retroknowledge"
+      CErrors.anomaly ~label:"Modops.add_retroknowledge"
         (Pp.str "had to import an unsupported kind of term")
   in
   fun lclrk env ->
diff --git a/kernel/names.ml b/kernel/names.ml
index f5d954e9..1eb9a317 100644
--- a/kernel/names.ml
+++ b/kernel/names.ml
@@ -23,6 +23,7 @@ open Util
 
 (** {6 Identifiers } *)
 
+(** Representation and operations on identifiers. *)
 module Id =
 struct
   type t = string
@@ -33,9 +34,15 @@ struct
 
   let hash = String.hash
 
+  let warn_invalid_identifier =
+    CWarnings.create ~name:"invalid-identifier" ~category:"parsing"
+                     ~default:CWarnings.Disabled
+                     (fun s -> str s)
+
   let check_soft ?(warn = true) x =
     let iter (fatal, x) =
-      if fatal then Errors.error x else if warn then Pp.msg_warning (str x)
+      if fatal then CErrors.error x else
+        if warn then warn_invalid_identifier x
     in
     Option.iter iter (Unicode.ident_refutation x)
 
@@ -74,10 +81,18 @@ struct
 
 end
 
-
+(** Representation and operations on identifiers that are allowed to be anonymous
+    (i.e. "_" in concrete syntax). *)
 module Name =
 struct
-  type t = Name of Id.t | Anonymous
+  type t = Anonymous     (** anonymous identifier *)
+	 | Name of Id.t  (** non-anonymous identifier *)
+
+  let is_anonymous = function
+    | Anonymous -> true
+    | Name _ -> false
+
+  let is_name = not % is_anonymous
 
   let compare n1 n2 = match n1, n2 with
     | Anonymous, Anonymous -> 0
@@ -102,7 +117,7 @@ struct
       let hashcons hident = function
         | Name id -> Name (hident id)
         | n -> n
-      let equal n1 n2 =
+      let eq n1 n2 =
         n1 == n2 ||
         match (n1,n2) with
           | (Name id1, Name id2) -> id1 == id2
@@ -117,8 +132,8 @@ struct
 
 end
 
-type name = Name.t = Name of Id.t | Anonymous
 (** Alias, to import constructors. *)
+type name = Name.t = Anonymous | Name of Id.t
 
 (** {6 Various types based on identifiers } *)
 
@@ -204,7 +219,7 @@ struct
     DirPath.to_string p ^ "." ^ s
 
   let debug_to_string (i, s, p) =
-    "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">"
+    "<"^DirPath.to_string p ^"#" ^ s ^"#"^ string_of_int i^">"
 
   let compare (x : t) (y : t) =
     if x == y then 0
@@ -236,7 +251,7 @@ struct
       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) =
+      let eq ((n1,s1,dir1) as x) ((n2,s2,dir2) as y) =
         (x == y) ||
         (Int.equal n1 n2 && s1 == s2 && dir1 == dir2)
       let hash = hash
@@ -282,6 +297,11 @@ module ModPath = struct
     | MPbound uid -> MBId.to_string uid
     | MPdot (mp,l) -> to_string mp ^ "." ^ Label.to_string l
 
+  let rec debug_to_string = function
+    | MPfile sl -> DirPath.to_string sl
+    | MPbound uid -> MBId.debug_to_string uid
+    | MPdot (mp,l) -> debug_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
@@ -327,7 +347,7 @@ module ModPath = struct
       | MPfile dir -> MPfile (hdir dir)
       | MPbound m -> MPbound (huniqid m)
       | MPdot (md,l) -> MPdot (hashcons hfuns md, hstr l)
-    let rec equal d1 d2 =
+    let eq d1 d2 =
       d1 == d2 ||
       match d1,d2 with
       | MPfile dir1, MPfile dir2 -> dir1 == dir2
@@ -375,12 +395,16 @@ module KerName = struct
   let modpath kn = kn.modpath
   let label kn = kn.knlabel
 
-  let to_string kn =
+  let to_string_gen mp_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
+    mp_to_string kn.modpath ^ dp ^ Label.to_string kn.knlabel
+
+  let to_string kn = to_string_gen ModPath.to_string kn
+
+  let debug_to_string kn = to_string_gen ModPath.debug_to_string kn
 
   let print kn = str (to_string kn)
 
@@ -423,7 +447,7 @@ module KerName = struct
     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 =
+    let eq kn1 kn2 =
       kn1.modpath == kn2.modpath && kn1.dirpath == kn2.dirpath &&
         kn1.knlabel == kn2.knlabel
     let hash = hash
@@ -477,7 +501,7 @@ module KerPair = struct
     | Dual (kn,_) -> kn
 
   let same kn = Same kn
-  let make knu knc = if knu == knc then Same knc else Dual (knu,knc)
+  let make knu knc = if KerName.equal knu knc then Same knc else Dual (knu,knc)
 
   let make1 = same
   let make2 mp l = same (KerName.make2 mp l)
@@ -500,9 +524,9 @@ module KerPair = struct
   let print kp = str (to_string kp)
 
   let debug_to_string = function
-    | Same kn -> "(" ^ KerName.to_string kn ^ ")"
+    | Same kn -> "(" ^ KerName.debug_to_string kn ^ ")"
     | Dual (knu,knc) ->
-      "(" ^ KerName.to_string knu ^ "," ^ KerName.to_string knc ^ ")"
+      "(" ^ KerName.debug_to_string knu ^ "," ^ KerName.debug_to_string knc ^ ")"
 
   let debug_print kp = str (debug_to_string kp)
 
@@ -524,6 +548,23 @@ module KerPair = struct
     let hash x = KerName.hash (canonical x)
   end
 
+  module SyntacticOrd = struct
+    type t = kernel_pair
+    let compare x y = match x, y with
+      | Same knx, Same kny -> KerName.compare knx kny
+      | Dual (knux,kncx), Dual (knuy,kncy) ->
+        let c = KerName.compare knux knuy in
+        if not (Int.equal c 0) then c
+        else KerName.compare kncx kncy
+      | Same _, _ -> -1
+      | Dual _, _ -> 1
+    let equal x y = x == y || compare x y = 0
+    let hash = function
+      | Same kn -> KerName.hash kn
+      | Dual (knu, knc) ->
+        Hashset.Combine.combine (KerName.hash knu) (KerName.hash knc)
+  end
+
   (** Default (logical) comparison and hash is on the canonical part *)
   let equal = CanOrd.equal
   let hash = CanOrd.hash
@@ -535,7 +576,7 @@ module KerPair = struct
       let hashcons hkn = function
         | Same kn -> Same (hkn kn)
         | Dual (knu,knc) -> make (hkn knu) (hkn knc)
-      let equal x y = (* physical comparison on subterms *)
+      let eq x y = (* physical comparison on subterms *)
         x == y ||
         match x,y with
         | Same x, Same y -> x == y
@@ -573,11 +614,16 @@ 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 *)
+(** Designation of a (particular) inductive type. *)
+type inductive = MutInd.t      (* the name of the inductive type *)
+               * int           (* the position of this inductive type
+                                  within the block of mutually-recursive inductive types.
+                                  BEWARE: indexing starts from 0. *)
 
-type inductive = MutInd.t * int
-type constructor = inductive * int
+(** Designation of a (particular) constructor of a (particular) inductive type. *)
+type constructor = inductive   (* designates the inductive type *)
+                 * int         (* the index of the constructor
+                                  BEWARE: indexing starts from 1. *)
 
 let ind_modpath (mind,_) = MutInd.modpath mind
 let constr_modpath (ind,_) = ind_modpath ind
@@ -590,6 +636,8 @@ 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 eq_syntactic_ind (m1, i1) (m2, i2) =
+  Int.equal i1 i2 && MutInd.SyntacticOrd.equal m1 m2
 
 let ind_ord (m1, i1) (m2, i2) =
   let c = Int.compare i1 i2 in
@@ -597,15 +645,22 @@ let ind_ord (m1, i1) (m2, i2) =
 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_syntactic_ord (m1, i1) (m2, i2) =
+  let c = Int.compare i1 i2 in
+  if Int.equal c 0 then MutInd.SyntacticOrd.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 ind_syntactic_hash (m, i) =
+  Hashset.Combine.combine (MutInd.SyntacticOrd.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 eq_syntactic_constructor (ind1, j1) (ind2, j2) =
+  Int.equal j1 j2 && eq_syntactic_ind ind1 ind2
 
 let constructor_ord (ind1, j1) (ind2, j2) =
   let c = Int.compare j1 j2 in
@@ -613,11 +668,16 @@ let constructor_ord (ind1, j1) (ind2, j2) =
 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_syntactic_ord (ind1, j1) (ind2, j2) =
+  let c = Int.compare j1 j2 in
+  if Int.equal c 0 then ind_syntactic_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)
+let constructor_syntactic_hash (ind, i) =
+  Hashset.Combine.combine (ind_syntactic_hash ind) (Int.hash i)
 
 module InductiveOrdered = struct
   type t = inductive
@@ -662,7 +722,7 @@ module Hind = Hashcons.Make(
     type t = inductive
     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 eq (mind1,i1) (mind2,i2) = mind1 == mind2 && Int.equal i1 i2
     let hash = ind_hash
   end)
 
@@ -671,7 +731,7 @@ module Hconstruct = Hashcons.Make(
     type t = constructor
     type u = inductive -> inductive
     let hashcons hind (ind, j) = (hind ind, j)
-    let equal (ind1, j1) (ind2, j2) = ind1 == ind2 && Int.equal j1 j2
+    let eq (ind1, j1) (ind2, j2) = ind1 == ind2 && Int.equal j1 j2
     let hash = constructor_hash
   end)
 
@@ -805,13 +865,22 @@ struct
 
   let hash (c, b) = (if b then 0 else 1) + Constant.hash c
 
+  module SyntacticOrd = struct
+    type t = constant * bool
+    let compare (c, b) (c', b') =
+      if b = b' then Constant.SyntacticOrd.compare c c' else -1
+    let equal (c, b as x) (c', b' as x') =
+      x == x' || b = b' && Constant.SyntacticOrd.equal c c'
+    let hash (c, b) = (if b then 0 else 1) + Constant.SyntacticOrd.hash c
+  end
+
   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) =
+      let eq ((c,b) as x) ((c',b') as y) =
         x == y || (c == c' && b == b')
       let hash = hash
     end
diff --git a/kernel/names.mli b/kernel/names.mli
index 72dff03b..feaedc77 100644
--- a/kernel/names.mli
+++ b/kernel/names.mli
@@ -6,34 +6,51 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(** This file defines a lot of different notions of names used pervasively in
+    the kernel as well as in other places. The essential datatypes exported by
+    this API are:
+
+    - Id.t is the type of identifiers, that is morally a subset of strings which
+      only contains Unicode characters of the Letter kind (and a few more).
+    - Name.t is an ad-hoc variant of Id.t option allowing to handle optionally
+      named objects.
+    - DirPath.t represents generic paths as sequences of identifiers.
+    - Label.t is an equivalent of Id.t made distinct for semantical purposes.
+    - ModPath.t are module paths.
+    - KerName.t are absolute names of objects in Coq.
+*)
+
 open Util
 
 (** {6 Identifiers } *)
 
+(** Representation and operations on identifiers. *)
 module Id :
 sig
   type t
-  (** Type of identifiers *)
+  (** Values of this type represent (Coq) identifiers. *)
 
   val equal : t -> t -> bool
-  (** Equality over identifiers *)
+  (** Equality over identifiers. *)
 
   val compare : t -> t -> int
-  (** Comparison over identifiers *)
+  (** Comparison over identifiers. *)
 
   val hash : t -> int
-  (** Hash over identifiers *)
+  (** Hash over identifiers. *)
 
   val is_valid : string -> bool
-  (** Check that a string may be converted to an identifier. *)
+  (** Check that a string may be converted to an identifier.
+  @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *)
 
   val of_string : string -> t
-  (** Converts a string into an identifier. May raise [UserError _] if the
-      string is not valid, or echo a warning if it contains invalid identifier
-      characters. *)
+  (** Converts a string into an identifier.
+      @raise UserError if the string is not valid, or echo a warning if it contains invalid identifier characters.
+      @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *)
 
   val of_string_soft : string -> t
-  (** Same as {!of_string} except that no warning is ever issued. *)
+  (** Same as {!of_string} except that no warning is ever issued.
+      @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *)
 
   val to_string : t -> string
   (** Converts a identifier into an string. *)
@@ -58,10 +75,18 @@ sig
 
 end
 
+(** Representation and operations on identifiers that are allowed to be anonymous
+    (i.e. "_" in concrete syntax). *)
 module Name :
 sig
-  type t = Name of Id.t | Anonymous
-  (** A name is either undefined, either an identifier. *)
+  type t = Anonymous     (** anonymous identifier *)
+	 | Name of Id.t  (** non-anonymous identifier *)
+
+  val is_anonymous : t -> bool
+  (** Return [true] iff a given name is [Anonymous]. *)
+
+  val is_name : t -> bool
+  (** Return [true] iff a given name is [Name _]. *)
 
   val compare : t -> t -> int
   (** Comparison over names. *)
@@ -79,7 +104,7 @@ end
 
 (** {6 Type aliases} *)
 
-type name = Name.t = Name of Id.t | Anonymous
+type name = Name.t = Anonymous | Name of Id.t
 type variable = Id.t
 type module_ident = Id.t
 
@@ -160,6 +185,8 @@ sig
   module Set : Set.S with type elt = t
   module Map : Map.ExtS with type key = t and module Set := Set
 
+  val hcons : t -> t
+
 end
 
 (** {6 Unique names for bound modules} *)
@@ -217,6 +244,9 @@ sig
 
   val to_string : t -> string
 
+  val debug_to_string : t -> string
+  (** Same as [to_string], but outputs information related to debug. *)
+
   val initial : t
   (** Name of the toplevel structure ([= MPfile initial_dir]) *)
 
@@ -244,6 +274,10 @@ sig
 
   (** Display *)
   val to_string : t -> string
+
+  val debug_to_string : t -> string
+  (** Same as [to_string], but outputs information related to debug. *)
+
   val print : t -> Pp.std_ppcmds
 
   (** Comparisons *)
@@ -305,6 +339,12 @@ sig
     val hash : t -> int
   end
 
+  module SyntacticOrd : 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] *)
 
@@ -379,6 +419,12 @@ sig
     val hash : t -> int
   end
 
+  module SyntacticOrd : 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] *)
 
@@ -397,11 +443,16 @@ 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 : CSig.MapS with type key = MutInd.t
 
-(** Beware: first inductive has index 0 *)
-type inductive = MutInd.t * int
+(** Designation of a (particular) inductive type. *)
+type inductive = MutInd.t      (* the name of the inductive type *)
+               * int           (* the position of this inductive type
+                                  within the block of mutually-recursive inductive types.
+                                  BEWARE: indexing starts from 0. *)
 
-(** Beware: first constructor has index 1 *)
-type constructor = inductive * int
+(** Designation of a (particular) constructor of a (particular) inductive type. *)
+type constructor = inductive   (* designates the inductive type *)
+                 * int         (* the index of the constructor
+                                  BEWARE: indexing starts from 1. *)
 
 module Indmap : CSig.MapS with type key = inductive
 module Constrmap : CSig.MapS with type key = constructor
@@ -417,16 +468,22 @@ 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 eq_syntactic_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 ind_syntactic_ord : inductive -> inductive -> int
+val ind_syntactic_hash : inductive -> int
 val eq_constructor : constructor -> constructor -> bool
 val eq_user_constructor : constructor -> constructor -> bool
+val eq_syntactic_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_ord : constructor -> constructor -> int
 val constructor_user_hash : constructor -> int
+val constructor_syntactic_ord : constructor -> constructor -> int
+val constructor_syntactic_hash : constructor -> int
 
 (** Better to have it here that in Closure, since required in grammar.cma *)
 type evaluable_global_reference =
@@ -640,6 +697,12 @@ module Projection : sig
     
   val make : constant -> bool -> t
 
+  module SyntacticOrd : sig
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val hash : t -> int
+  end
+
   val constant : t -> constant
   val unfolded : t -> bool
   val unfold : t -> t
@@ -717,7 +780,7 @@ 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] *)
+(** @deprecated Same as [MutInd.make] *)
 
 val make_mind : ModPath.t -> DirPath.t -> Label.t -> mutual_inductive
 (** @deprecated Same as [MutInd.make3] *)
diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml
index 9d181b47..eaddace4 100644
--- a/kernel/nativecode.ml
+++ b/kernel/nativecode.ml
@@ -5,10 +5,10 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-open Errors
+
+open CErrors
 open Names
 open Term
-open Context
 open Declarations
 open Util
 open Nativevalues
@@ -22,8 +22,12 @@ to OCaml code. *)
 
 (** Local names **)
 
+(* The first component is there for debugging purposes only *)
 type lname = { lname : name; luid : int }
 
+let eq_lname ln1 ln2 =
+  Int.equal ln1.luid ln2.luid
+
 let dummy_lname = { lname = Anonymous; luid = -1 }
 
 module LNord = 
@@ -82,6 +86,9 @@ let eq_gname gn1 gn2 =
   | Gnamed id1, Gnamed id2 -> Id.equal id1 id2
   | _ -> false
 
+let dummy_gname =
+  Grel 0
+
 open Hashset.Combine
 
 let gname_hash gn = match gn with
@@ -404,9 +411,13 @@ let opush_lnames n env lns =
 let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 =
   match t1, t2 with
   | MLlocal ln1, MLlocal ln2 ->
+     (try
       Int.equal (LNmap.find ln1 env1) (LNmap.find ln2 env2)
+     with Not_found ->
+      eq_lname ln1 ln2)
   | MLglobal gn1', MLglobal gn2' ->
       eq_gname gn1' gn2' || (eq_gname gn1 gn1' && eq_gname gn2 gn2')
+      || (eq_gname gn1 gn2' && eq_gname gn2 gn1')
   | MLprimitive prim1, MLprimitive prim2 -> eq_primitive prim1 prim2
   | MLlam (lns1, ml1), MLlam (lns2, ml2) ->
       Int.equal (Array.length lns1) (Array.length lns2) &&
@@ -719,6 +730,11 @@ let push_global_norm gn params body =
 let push_global_case gn params annot a accu bs =
   push_global gn (Gletcase (gn, params, annot, a, accu, bs))
 
+(* Compares [t1] and [t2] up to alpha-equivalence. [t1] and [t2] may contain
+   free variables. *)
+let eq_mllambda t1 t2 =
+  eq_mllambda dummy_gname dummy_gname 0 LNmap.empty LNmap.empty t1 t2
+
 (*s Compilation environment *)
 
 type env =
@@ -897,9 +913,7 @@ let rec insert cargs body rl =
      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
+     if eq_mllambda body body' then
        let (c,params) = cargs in
        let params = rm_params fv params in
        l := (c,params)::!l
@@ -1446,12 +1460,14 @@ let optimize gdef l =
 
 	end
     | MLif(t,b1,b2) ->
+       (* This optimization is critical: it applies to all fixpoints that start
+       by matching on their recursive argument *)
 	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 *)
+	    when eq_mllambda l1 l2 -> MLmatch(annot, l1, b1, bs)
         | _, _ -> MLif(t, b1, b2)
 	end
     | MLmatch(annot,a,accu,bs) ->
@@ -1487,8 +1503,8 @@ let optimize_stk 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_id s = Unicode.ascii_of_ident (Id.to_string s)
+let string_of_label l = string_of_id (Label.to_id l)
 
 let string_of_dirpath = function
   | [] -> "_"
@@ -1561,8 +1577,7 @@ 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
+  Format.fprintf fmt "x_%s_%i" (string_of_name ln.lname) ln.luid
 
 let pp_ldecls fmt ids =
   let len = Array.length ids in
@@ -1826,31 +1841,32 @@ and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml =
   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 lvl = Context.Rel.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 open Context.Rel in
+  let n = length env.env_rel_context - n in
+  let open Declaration in
+  match lookup n env.env_rel_context with
+  | LocalDef (_,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 -> 
+  | LocalAssum _ ->
       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 open Context.Named.Declaration in
+  match lookup_named id env with
+  | LocalDef (_,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 -> 
+  | LocalAssum _ ->
       Glet(Gnamed id, MLprimitive (Mk_var id))::auxdefs
 
 let compile_constant env sigma prefix ~interactive con cb =
@@ -1864,7 +1880,7 @@ let compile_constant env sigma prefix ~interactive con cb =
     | 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");
+      if !Flags.debug then Feedback.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 =
@@ -1879,11 +1895,11 @@ let compile_constant env sigma prefix ~interactive con cb =
 	  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");
+      if !Flags.debug then Feedback.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");
+      if !Flags.debug then Feedback.msg_debug (Pp.str "Optimized mllambda code");
       code, name
     | _ -> 
         let i = push_symbol (SymbConst con) in
@@ -1930,13 +1946,15 @@ let compile_constant env sigma prefix ~interactive con cb =
           arg|])))::
             [Glet(gn, mkMLlam [|c_uid|] code)], Linked prefix
 
-let loaded_native_files = ref ([] : string list)
+module StringOrd = struct type t = string let compare = String.compare end
+module StringSet = Set.Make(StringOrd)
+
+let loaded_native_files = ref StringSet.empty
 
-let is_loaded_native_file s = String.List.mem s !loaded_native_files
+let is_loaded_native_file s = StringSet.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
+  loaded_native_files := StringSet.add s !loaded_native_files
 
 let is_code_loaded ~interactive name =
   match !name with
diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml
index 7ac5b8d7..3c0afe38 100644
--- a/kernel/nativeconv.ml
+++ b/kernel/nativeconv.ml
@@ -5,9 +5,9 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-open Errors
+
+open CErrors
 open Names
-open Univ
 open Nativelib
 open Reduction
 open Util
@@ -135,22 +135,27 @@ let native_conv_gen pb sigma env univs t1 t2 =
   match compile ml_filename code with
   | (true, fn) ->
       begin
-        if !Flags.debug then Pp.msg_debug (Pp.str "Running test...");
+        if !Flags.debug then Feedback.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);
+        if !Flags.debug then Feedback.msg_debug (Pp.str time_info);
         (* TODO change 0 when we can have deBruijn *)
         fst (conv_val env pb 0 !rt1 !rt2 univs)
       end
   | _ -> anomaly (Pp.str "Compilation failure") 
 
+let warn_no_native_compiler =
+  let open Pp in
+  CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler"
+         (fun () -> strbrk "Native compiler is disabled," ++
+                      strbrk " falling back to VM conversion test.")
+
 (* Wrapper for [native_conv] above *)
 let native_conv cv_pb sigma env t1 t2 =
   if Coq_config.no_native_compiler then begin
-    let msg = "Native compiler is disabled, falling back to VM conversion test." in
-    Pp.msg_warning (Pp.str msg);
+    warn_no_native_compiler ();
     vm_conv cv_pb env t1 t2
   end
   else
diff --git a/kernel/nativeconv.mli b/kernel/nativeconv.mli
index 6c0b310c..63b1eb05 100644
--- a/kernel/nativeconv.mli
+++ b/kernel/nativeconv.mli
@@ -11,7 +11,7 @@ open Nativelambda
 
 (** This module implements the conversion test by compiling to OCaml code *)
 
-val native_conv : conv_pb -> evars -> types conversion_function
+val native_conv : conv_pb -> evars -> types kernel_conversion_function
 
 (** A conversion function parametrized by a universe comparator. Used outside of
     the kernel. *)
diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml
index f10db224..91b40be7 100644
--- a/kernel/nativelambda.ml
+++ b/kernel/nativelambda.ml
@@ -485,7 +485,7 @@ module Renv =
     let pop env = Vect.pop env.name_rel
 	    
     let popn env n =
-      for i = 1 to n do pop env done
+      for _i = 1 to n do pop env done
 
     let get env n =
       Lrel (Vect.get_last env.name_rel (n-1), n)
@@ -727,7 +727,8 @@ let optimize 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
+  let open Context.Rel.Declaration in
+  let ids = List.rev_map get_name !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
diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml
index 948989fd..1c58c744 100644
--- a/kernel/nativelib.ml
+++ b/kernel/nativelib.ml
@@ -8,7 +8,7 @@
 open Util
 open Nativevalues
 open Nativecode
-open Errors
+open CErrors
 open Envars
 
 (** This file provides facilities to access OCaml compiler and dynamic linker,
@@ -30,10 +30,6 @@ 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
@@ -59,6 +55,15 @@ let write_ml_code fn ?(header=[]) code =
   List.iter (pp_global fmt) (header@code);
   close_out ch_out
 
+let warn_native_compiler_failed =
+  let print = function
+  | Inl (Unix.WEXITED n) -> Pp.(strbrk "Native compiler exited with status" ++ str" " ++ int n)
+  | Inl (Unix.WSIGNALED n) -> Pp.(strbrk "Native compiler killed by signal" ++ str" " ++ int n)
+  | Inl (Unix.WSTOPPED n) -> Pp.(strbrk "Native compiler stopped by signal" ++ str" " ++ int n)
+  | Inr e -> Pp.(strbrk "Native compiler failed with error: " ++ strbrk (Unix.error_message e))
+  in
+  CWarnings.create ~name:"native-compiler-failed" ~category:"native-compiler" print
+
 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
@@ -70,26 +75,24 @@ let call_compiler ml_filename =
   remove link_filename;
   remove (f ^ ".cmi");
   let args =
-    (if Dynlink.is_native then "-shared" else "-c")
+    (if Dynlink.is_native then "opt" else "ocamlc")
+    ::(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)));
+  if !Flags.debug then Feedback.msg_debug (Pp.str (ocamlfind () ^ " " ^ (String.concat " " args)));
   try
-    let res = CUnix.sys_command compiler_name args in
+    let res = CUnix.sys_command (ocamlfind ()) args in
     let res = match res with
       | Unix.WEXITED 0 -> true
-      | Unix.WEXITED n ->
-         Pp.(msg_warning (str "command exited with status " ++ int n)); false
-      | Unix.WSIGNALED n ->
-         Pp.(msg_warning (str "command killed by signal " ++ int n)); false
-      | Unix.WSTOPPED n ->
-         Pp.(msg_warning (str "command stopped by signal " ++ int n)); false in
+      | Unix.WEXITED n | Unix.WSIGNALED n | Unix.WSTOPPED n ->
+        warn_native_compiler_failed (Inl res); false
+    in
     res, link_filename
   with Unix.Unix_error (e,_,_) ->
-    Pp.(msg_warning (str (Unix.error_message e)));
+    warn_native_compiler_failed (Inr e);
     false, link_filename
 
 let compile fn code =
@@ -122,18 +125,18 @@ let call_linker ?(fatal=true) prefix f upds =
   if not (Sys.file_exists f) then
     begin
       let msg = "Cannot find native compiler file " ^ f in
-      if fatal then Errors.error msg
-      else if !Flags.debug then Pp.msg_debug (Pp.str msg)
+      if fatal then CErrors.error msg
+      else if !Flags.debug then Feedback.msg_debug (Pp.str msg)
     end
   else
   (try
     if Dynlink.is_native then Dynlink.loadfile f else !load_obj f;
     register_native_file prefix
    with Dynlink.Error e as exn ->
-     let exn = Errors.push exn in
+     let exn = CErrors.push exn in
      let msg = "Dynlink error, " ^ Dynlink.error_message e in
-     if fatal then (Pp.msg_error (Pp.str msg); iraise exn)
-     else if !Flags.debug then Pp.msg_debug (Pp.str msg));
+     if fatal then (Feedback.msg_error (Pp.str msg); iraise exn)
+     else if !Flags.debug then Feedback.msg_debug (Pp.str msg));
   match upds with Some upds -> update_locations upds | _ -> ()
 
 let link_library ~prefix ~dirname ~basename =
diff --git a/kernel/nativelibrary.ml b/kernel/nativelibrary.ml
index 9d159be6..246b00da 100644
--- a/kernel/nativelibrary.ml
+++ b/kernel/nativelibrary.ml
@@ -29,13 +29,13 @@ and translate_field prefix mp env acc (l,x) =
      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));
+	Feedback.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));
+	Feedback.msg_debug (Pp.str msg));
      compile_mind_field prefix mp l acc mb
   | SFBmodule md ->
      let mp = md.mod_mp in
@@ -43,7 +43,7 @@ and translate_field prefix mp env acc (l,x) =
 	let msg =
 	  Printf.sprintf "Compiling module %s..." (ModPath.to_string mp)
 	in
-	Pp.msg_debug (Pp.str msg));
+	Feedback.msg_debug (Pp.str msg));
      translate_mod prefix mp env md.mod_type acc
   | SFBmodtype mdtyp ->
      let mp = mdtyp.mod_mp in
@@ -51,11 +51,11 @@ and translate_field prefix mp env acc (l,x) =
 	let msg =
 	  Printf.sprintf "Compiling module type %s..." (ModPath.to_string mp)
 	in
-	Pp.msg_debug (Pp.str msg));
+	Feedback.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...");
+  if !Flags.debug then Feedback.msg_debug (Pp.str "Compiling library...");
   match mod_expr with
   | NoFunctor struc ->
       let env = add_structure mp struc empty_delta_resolver env in
diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml
index 5712c997..8093df30 100644
--- a/kernel/nativevalues.ml
+++ b/kernel/nativevalues.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 open Term
 open Names
-open Errors
+open CErrors
 open Util
 
 (** This module defines the representation of values internally used by
@@ -78,8 +78,6 @@ let accumulate_code (k:accumulator) (x: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
@@ -160,31 +158,6 @@ 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))
 
diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml
index 7d801902..130f1eb0 100644
--- a/kernel/opaqueproof.ml
+++ b/kernel/opaqueproof.ml
@@ -16,7 +16,7 @@ type work_list = (Instance.t * Id.t array) Cmap.t *
 
 type cooking_info = { 
   modlist : work_list; 
-  abstract : Context.named_context * Univ.universe_level_subst * Univ.UContext.t } 
+  abstract : Context.Named.t * 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 *)
@@ -26,10 +26,10 @@ let empty_opaquetab = Int.Map.empty, DirPath.initial
 
 (* hooks *)
 let default_get_opaque dp _ =
-  Errors.error
+  CErrors.error
     ("Cannot access opaque proofs in library " ^ DirPath.to_string dp)
 let default_get_univ dp _ =
-  Errors.error
+  CErrors.error
     ("Cannot access universe constraints of opaque proofs in library " ^
     DirPath.to_string dp)
 
@@ -45,8 +45,8 @@ let create cu = Direct ([],cu)
 let turn_indirect dp o (prfs,odp) = match o with
   | Indirect (_,_,i) ->
       if not (Int.Map.mem i prfs)
-      then Errors.anomaly (Pp.str "Indirect in a different table")
-      else Errors.anomaly (Pp.str "Already an indirect opaque")
+      then CErrors.anomaly (Pp.str "Indirect in a different table")
+      else CErrors.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
@@ -54,21 +54,21 @@ let turn_indirect dp o (prfs,odp) = match o with
       let ndp =
         if DirPath.equal dp odp then odp
         else if DirPath.equal odp DirPath.initial then dp
-        else Errors.anomaly
+        else CErrors.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")
+  | Direct _ -> CErrors.anomaly (Pp.str "Substituting a Direct opaque")
 
 let iter_direct_opaque f = function
-  | Indirect _ -> Errors.anomaly (Pp.str "Not a direct opaque")
+  | Indirect _ -> CErrors.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")
+  | Indirect _ -> CErrors.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))
 
diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli
index 9fd7172a..5139cf05 100644
--- a/kernel/opaqueproof.mli
+++ b/kernel/opaqueproof.mli
@@ -48,7 +48,7 @@ type work_list = (Univ.Instance.t * Id.t array) Cmap.t *
 
 type cooking_info = { 
   modlist : work_list; 
-  abstract : Context.named_context * Univ.universe_level_subst * Univ.UContext.t } 
+  abstract : Context.Named.t * Univ.universe_level_subst * Univ.UContext.t } 
 
 (* The type has two caveats:
    1) cook_constr is defined after
diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
index e1fe0259..7be8606e 100644
--- a/kernel/pre_env.ml
+++ b/kernel/pre_env.ml
@@ -15,17 +15,16 @@
 
 open Util
 open Names
-open Context
-open Univ
 open Term
 open Declarations
+open Context.Named.Declaration
 
 (* 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 CEphemeron.key option ref 
 
 (** Linking information for the native compiler. *)
 
@@ -45,41 +44,45 @@ type globals = {
   env_modtypes : module_type_body MPmap.t}
 
 type stratification = {
-  env_universes : universes;
+  env_universes : UGraph.t;
   env_engagement : engagement
 }
 
 type val_kind =
-    | VKvalue of (values * Id.Set.t) Ephemeron.key
+    | VKvalue of (values * Id.Set.t) CEphemeron.key
     | VKnone
 
 type lazy_val = val_kind ref
 
 let force_lazy_val vk = match !vk with
 | VKnone -> None
-| VKvalue v -> try Some (Ephemeron.get v) with Ephemeron.InvalidKey -> None
+| VKvalue v -> try Some (CEphemeron.get v) with CEphemeron.InvalidKey -> None
 
 let dummy_lazy_val () = ref VKnone
-let build_lazy_val vk key = vk := VKvalue (Ephemeron.create key)
+let build_lazy_val vk key = vk := VKvalue (CEphemeron.create key)
 
-type named_vals = (Id.t * lazy_val) list
+type named_context_val = {
+  env_named_ctx : Context.Named.t;
+  env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t;
+}
 
 type env = {
   env_globals       : globals;
-  env_named_context : named_context;
-  env_named_vals    : named_vals;
-  env_rel_context   : rel_context;
+  env_named_context : named_context_val;
+  env_rel_context   : Context.Rel.t;
   env_rel_val       : lazy_val list;
   env_nb_rel        : int;
   env_stratification : stratification;
+  env_typing_flags  : typing_flags;
   env_conv_oracle   : Conv_oracle.oracle;
   retroknowledge : Retroknowledge.retroknowledge;
   indirect_pterms : Opaqueproof.opaquetab;
 }
 
-type named_context_val = named_context * named_vals
-
-let empty_named_context_val = [],[]
+let empty_named_context_val = {
+  env_named_ctx = [];
+  env_named_map = Id.Map.empty;
+}
 
 let empty_env = {
   env_globals = {
@@ -87,14 +90,14 @@ let empty_env = {
     env_inductives = Mindmap_env.empty;
     env_modules = MPmap.empty;
     env_modtypes = MPmap.empty};
-  env_named_context = empty_named_context;
-  env_named_vals = [];
-  env_rel_context = empty_rel_context;
+  env_named_context = empty_named_context_val;
+  env_rel_context = Context.Rel.empty;
   env_rel_val = [];
   env_nb_rel = 0;
   env_stratification = {
-    env_universes = initial_universes;
-    env_engagement = (PredicativeSet,StratifiedType) };
+    env_universes = UGraph.initial_universes;
+    env_engagement = PredicativeSet };
+  env_typing_flags = Declareops.safe_flags;
   env_conv_oracle = Conv_oracle.empty;
   retroknowledge = Retroknowledge.initial_retroknowledge;
   indirect_pterms = Opaqueproof.empty_opaquetab }
@@ -107,7 +110,7 @@ let nb_rel env = env.env_nb_rel
 let push_rel d env =
   let rval = ref VKnone in
     { env with
-      env_rel_context = add_rel_decl d env.env_rel_context;
+      env_rel_context = Context.Rel.add d env.env_rel_context;
       env_rel_val = rval :: env.env_rel_val;
       env_nb_rel = env.env_nb_rel + 1 }
 
@@ -124,30 +127,57 @@ let env_of_rel n env =
 
 (* Named context *)
 
-let push_named_context_val d (ctxt,vals) =
-  let id,_,_ = d in
-  let rval = ref VKnone in
-    add_named_decl d ctxt, (id,rval)::vals
+let push_named_context_val_val d rval ctxt =
+(*   assert (not (Id.Map.mem (get_id d) ctxt.env_named_map)); *)
+  {
+    env_named_ctx = Context.Named.add d ctxt.env_named_ctx;
+    env_named_map = Id.Map.add (get_id d) (d, rval) ctxt.env_named_map;
+  }
+
+let push_named_context_val d ctxt =
+  push_named_context_val_val d (ref VKnone) ctxt
+
+let match_named_context_val c = match c.env_named_ctx with
+| [] -> None
+| decl :: ctx ->
+  let (_, v) = Id.Map.find (get_id decl) c.env_named_map in
+  let map = Id.Map.remove (get_id decl) c.env_named_map in
+  let cval = { env_named_ctx = ctx; env_named_map = map } in
+  Some (decl, v, cval)
+
+let map_named_val f ctxt =
+  let open Context.Named.Declaration in
+  let fold accu d =
+    let d' = map_constr f d in
+    let accu =
+      if d == d' then accu
+      else Id.Map.modify (get_id d) (fun _ (_, v) -> (d', v)) accu
+    in
+    (accu, d')
+  in
+  let map, ctx = List.fold_map fold ctxt.env_named_map ctxt.env_named_ctx in
+  { env_named_ctx = ctx; env_named_map = map }
 
 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_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_named_context = push_named_context_val d env.env_named_context;
     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_typing_flags = env.env_typing_flags;
     env_conv_oracle = env.env_conv_oracle;
     retroknowledge = env.retroknowledge;
     indirect_pterms = env.indirect_pterms;
   }
 
+let lookup_named id env =
+  fst (Id.Map.find id env.env_named_context.env_named_map)
+
 let lookup_named_val id env =
-  snd(List.find (fun (id',_) -> Id.equal id id') env.env_named_vals)
+  snd(Id.Map.find id env.env_named_context.env_named_map)
 
 (* Warning all the names should be different *)
 let env_of_named id env = env
diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli
index 23f9a3f4..86679036 100644
--- a/kernel/pre_env.mli
+++ b/kernel/pre_env.mli
@@ -8,9 +8,7 @@
 
 open Names
 open Term
-open Context
 open Declarations
-open Univ
 
 (** The type of environments. *)
 
@@ -19,7 +17,7 @@ type link_info =
   | LinkedInteractive of string
   | NotLinked
 
-type key = int Ephemeron.key option ref 
+type key = int CEphemeron.key option ref 
 
 type constant_key = constant_body * (link_info ref * key)
 
@@ -32,7 +30,7 @@ type globals = {
   env_modtypes : module_type_body MPmap.t}
 
 type stratification = {
-  env_universes : universes;
+  env_universes : UGraph.t;
   env_engagement : engagement
 }
 
@@ -42,23 +40,24 @@ 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 = (Id.t * lazy_val) list
+type named_context_val = private {
+  env_named_ctx : Context.Named.t;
+  env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t;
+}
 
 type env = {
     env_globals       : globals;
-    env_named_context : named_context;
-    env_named_vals    : named_vals;
-    env_rel_context   : rel_context;
+    env_named_context : named_context_val;
+    env_rel_context   : Context.Rel.t;
     env_rel_val       : lazy_val list;
     env_nb_rel        : int;
     env_stratification : stratification;
+    env_typing_flags  : typing_flags;
     env_conv_oracle   : Conv_oracle.oracle;
     retroknowledge : Retroknowledge.retroknowledge;
     indirect_pterms : Opaqueproof.opaquetab;
 }
 
-type named_context_val = named_context * named_vals
-
 val empty_named_context_val : named_context_val
 
 val empty_env : env
@@ -66,15 +65,23 @@ val empty_env : env
 (** Rel context *)
 
 val nb_rel         : env -> int
-val push_rel       : rel_declaration -> env -> env
+val push_rel       : Context.Rel.Declaration.t -> env -> env
 val lookup_rel_val : int -> env -> lazy_val
 val env_of_rel     : int -> env -> env
 
 (** Named context *)
 
 val push_named_context_val  :
-    named_declaration -> named_context_val -> named_context_val
-val push_named       : named_declaration -> env -> env
+    Context.Named.Declaration.t -> named_context_val -> named_context_val
+val push_named_context_val_val  :
+    Context.Named.Declaration.t -> lazy_val -> named_context_val -> named_context_val
+val match_named_context_val  :
+  named_context_val -> (Context.Named.Declaration.t * lazy_val * named_context_val) option
+val map_named_val :
+   (constr -> constr) -> named_context_val -> named_context_val
+
+val push_named       : Context.Named.Declaration.t -> env -> env
+val lookup_named     : Id.t -> env -> Context.Named.Declaration.t
 val lookup_named_val : Id.t -> env -> lazy_val
 val env_of_named     : Id.t -> env -> env
 
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index 97c3e1b3..1ae89347 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -15,16 +15,15 @@
 (* Equal inductive types by Jacek Chrzaszcz as part of the module
    system, Aug 2002 *)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Term
 open Vars
-open Context
-open Univ
 open Environ
-open Closure
+open CClosure
 open Esubst
+open Context.Rel.Declaration
 
 let rec is_empty_stack = function
   [] -> true
@@ -54,8 +53,7 @@ let compare_stack_shape stk1 stk2 =
     | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 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) ->
+    | (ZcaseT(c1,_,_,_)::s1, ZcaseT(c2,_,_,_)::s2) ->
         Int.equal bal 0 (* && c1.ci_ind  = c2.ci_ind *) && compare_rec 0 s1 s2
     | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) ->
         Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2
@@ -89,9 +87,8 @@ let pure_stack lfts stk =
                 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
+                (l,Zlcase(ci,l,mk_clos e p,Array.map (mk_clos e) br)::pstk))
+  in
   snd (pure_rec lfts stk)
 
 (****************************************************************************)
@@ -110,46 +107,32 @@ let whd_betaiotazeta env x =
        Prod _|Lambda _|Fix _|CoFix _) -> x
     | _ -> whd_val (create_clos_infos betaiotazeta env) (inject x)
 
-let whd_betadeltaiota env t =
+let whd_all env t =
   match kind_of_term t with
     | (Sort _|Meta _|Evar _|Ind _|Construct _|
        Prod _|Lambda _|Fix _|CoFix _) -> t
-    | _ -> whd_val (create_clos_infos betadeltaiota env) (inject t)
+    | _ -> whd_val (create_clos_infos all env) (inject t)
 
-let whd_betadeltaiota_nolet env t =
+let whd_allnolet env t =
   match kind_of_term t with
     | (Sort _|Meta _|Evar _|Ind _|Construct _|
        Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t
-    | _ -> whd_val (create_clos_infos betadeltaiotanolet env) (inject t)
-
-(* Beta *)
-
-let beta_appvect c v =
-  let rec stacklam env t stack =
-    match kind_of_term t, stack with
-        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 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) (substl env b::env) c stack
-      | _ -> anomaly (Pp.str "Not enough lambda/let's") in
-  stacklam n [] c (Array.to_list v)
+    | _ -> whd_val (create_clos_infos allnolet env) (inject t)
 
 (********************************************************************)
 (*                         Conversion                               *)
 (********************************************************************)
 
 (* Conversion utility functions *)
-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
+
+(* functions of this type are called from the kernel *)
+type 'a kernel_conversion_function = env -> 'a -> 'a -> unit
+
+(* functions of this type can be called from outside the kernel *)
+type 'a extended_conversion_function =
+  ?l2r:bool -> ?reds:Names.transparent_state -> env ->
+  ?evars:((existential->constr option) * UGraph.t) ->
+  'a -> 'a -> unit
 
 exception NotConvertible
 exception NotConvertibleVect of int
@@ -180,7 +163,7 @@ 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
+type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.constraints
 
 let sort_cmp_universes env pb s0 s1 (u, check) =
   (check.compare env pb s0 s1 u, check)
@@ -193,7 +176,7 @@ let convert_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' ->
+  | ConstKey (cst, u), ConstKey (cst', u') when Constant.equal cst cst' ->
     if Univ.Instance.equal u u' then cuniv
     else 
       let flex = evaluable_constant cst (info_env infos) 
@@ -235,7 +218,6 @@ let rec no_arg_available = function
   | Zshift _ :: stk -> 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
 
@@ -248,7 +230,6 @@ let rec no_nth_arg_available n = function
       if n >= k then no_nth_arg_available (n-k) stk
       else false
   | Zproj _ :: _ -> true
-  | Zcase _ :: _ -> true
   | ZcaseT _ :: _ -> true
   | Zfix _ :: _ -> true
 
@@ -258,13 +239,12 @@ let rec no_case_available = function
   | 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 _ | FCase _ | FCaseT _ | FApp _ 
+    | (FLetIn _ | FCaseT _ | FApp _ 
 	  | FCLOS _ | FLIFT _ | FCast _) -> false
     | FLambda _ -> no_arg_available stk
     | FConstruct _ -> no_case_available stk
@@ -336,9 +316,9 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv =
       (try
 	 let cuniv = conv_table_key infos fl1 fl2 cuniv in
 	   convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
-       with NotConvertible ->
+       with NotConvertible | Univ.UniverseInconsistency _ ->
            (* else the oracle tells which constant is to be expanded *)
-	 let oracle = Closure.oracle_of_infos infos in
+	 let oracle = CClosure.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
@@ -530,8 +510,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv =
         else raise NotConvertible
 
      (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *)
-     | ( (FLetIn _, _) | (FCase _,_) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_)
-       | (_, FLetIn _) | (_,FCase _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _)
+     | ( (FLetIn _, _) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_)
+       | (_, FLetIn _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _)
        | (FLOCKED,_) | (_,FLOCKED) ) -> assert false
 
      (* In all other cases, terms are not convertible *)
@@ -556,17 +536,17 @@ and convert_vect l2r infos lft1 lft2 v1 v2 cuniv =
     fold 0 cuniv
   else raise NotConvertible
 
-let clos_fconv trans cv_pb l2r evars env univs t1 t2 =
-  let reds = Closure.RedFlags.red_add_transparent betaiotazeta trans in
+let clos_gen_conv trans cv_pb l2r evars env univs t1 t2 =
+  let reds = CClosure.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
+  if not (UGraph.check_eq univs u u') then raise NotConvertible
 
 let check_leq univs u u' = 
-  if not (check_leq univs u u') then raise NotConvertible
+  if not (UGraph.check_leq univs u u') then raise NotConvertible
 
 let check_sort_cmp_universes env pb s0 s1 univs =
   match (s0,s1) with
@@ -593,7 +573,7 @@ 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
+  if UGraph.check_eq_instances univs u u' then univs
   else raise NotConvertible
 
 let checked_universes =
@@ -601,12 +581,12 @@ let checked_universes =
     compare_instances = check_convert_instances }
 
 let infer_eq (univs, cstrs as cuniv) u u' =
-  if Univ.check_eq univs u u' then cuniv
+  if UGraph.check_eq univs u u' then cuniv
   else
     univs, (Univ.enforce_eq u u' cstrs)
 
 let infer_leq (univs, cstrs as cuniv) u u' =
-  if Univ.check_leq univs u u' then cuniv
+  if UGraph.check_leq univs u u' then cuniv
   else
     let cstrs' = Univ.enforce_leq u u' cstrs in
       univs, cstrs'
@@ -635,57 +615,35 @@ let infer_cmp_universes env pb s0 s1 univs =
 let infer_convert_instances ~flex u u' (univs,cstrs) =
   (univs, Univ.enforce_eq_instances u u' cstrs)
 
-let inferred_universes : (Univ.universes * Univ.Constraint.t) universe_compare =
+let inferred_universes : (UGraph.t * 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 gen_conv cv_pb l2r reds env evars 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
+      let _ = clos_gen_conv reds cv_pb l2r evars env (univs, checked_universes) t1 t2 in
 	()
 
 (* Profiling *)
-let trans_fconv_universes = 
+let gen_conv cv_pb ?(l2r=false) ?(reds=full_transparent_state) env ?(evars=(fun _->None), universes env) =
+  let evars, univs = evars in
   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 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 full_transparent_state
+    let fconv_universes_key = Profile.declare_profile "trans_fconv_universes" in
+      Profile.profile8 fconv_universes_key gen_conv cv_pb l2r reds env evars univs
+  else gen_conv cv_pb l2r reds env evars univs
 
-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 = gen_conv CONV
 
-let conv_leq_vecti ?(l2r=false) ?(evars=fun _->None) env v1 v2 =
-  Array.fold_left2_i
-    (fun i _ t1 t2 ->
-      try conv_leq ~l2r ~evars env t1 t2
-      with NotConvertible -> raise (NotConvertibleVect i))
-    ()
-    v1
-    v2
+let conv_leq = gen_conv CUMUL
 
 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 
+    clos_gen_conv reds cv_pb l2r evars env univs t1 t2 
   in s
 
 let infer_conv_universes cv_pb l2r evars reds env univs t1 t2 =
@@ -696,7 +654,7 @@ let infer_conv_universes cv_pb l2r evars reds env univs t1 t2 =
     if b then cstrs
     else
       let univs = ((univs, Univ.Constraint.empty), inferred_universes) in
-      let ((_,cstrs), _) = clos_fconv reds cv_pb l2r evars env univs t1 t2 in
+      let ((_,cstrs), _) = clos_gen_conv reds cv_pb l2r evars env univs t1 t2 in
 	cstrs
 
 (* Profiling *)
@@ -715,18 +673,25 @@ let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_sta
   infer_conv_universes CUMUL l2r evars ts env univs t1 t2
 
 (* This reference avoids always having to link C code with the kernel *)
-let vm_conv = ref (fun cv_pb -> fconv cv_pb false (fun _->None))
-let set_vm_conv f = vm_conv := f
+let vm_conv = ref (fun cv_pb env ->
+		   gen_conv cv_pb env ~evars:((fun _->None), universes env))
+
+let warn_bytecode_compiler_failed =
+  let open Pp in
+  CWarnings.create ~name:"bytecode-compiler-failed" ~category:"bytecode-compiler"
+         (fun () -> strbrk "Bytecode compiler failed, " ++
+                      strbrk "falling back to standard conversion")
+
+let set_vm_conv (f:conv_pb -> Term.types kernel_conversion_function) = vm_conv := f
 let vm_conv cv_pb env t1 t2 =
   try
     !vm_conv cv_pb env t1 t2
   with Not_found | Invalid_argument _ ->
-    (Pp.msg_warning
-      (Pp.str "Bytecode compilation failed, falling back to default conversion");
-     fconv cv_pb false (fun _->None) env t1 t2)
+    warn_bytecode_compiler_failed ();
+    gen_conv cv_pb env t1 t2
 
 let default_conv cv_pb ?(l2r=false) env t1 t2 =
-    fconv cv_pb false (fun _ -> None) env t1 t2
+    gen_conv cv_pb env t1 t2
 
 let default_conv_leq = default_conv CUMUL
 (*
@@ -739,18 +704,34 @@ let conv env t1 t2 =
   Profile.profile4 convleqkey conv env t1 t2;;
 *)
 
+(* Application with on-the-fly reduction *)
+
+let beta_applist c l =
+  let rec app subst c l =
+    match kind_of_term c, l with
+    | Lambda(_,_,c), arg::l -> app (arg::subst) c l
+    | _ -> applist (substl subst c, l) in
+  app [] c l
+
+let beta_appvect c v = beta_applist c (Array.to_list v)
+
+let beta_app c a = beta_applist c [a]
+
+(* Compatibility *)
+let betazeta_appvect = lambda_appvect_assum
+
 (********************************************************************)
 (*             Special-Purpose Reduction                            *)
 (********************************************************************)
 
 (* pseudo-reduction rule:
- * [hnf_prod_app env s (Prod(_,B)) N --> B[N]
+ * [hnf_prod_app env (Prod(_,B)) N --> B[N]
  * with an HNF on the first argument to produce a product.
  * if this does not work, then we use the string S as part of our
  * error message. *)
 
 let hnf_prod_app env t n =
-  match kind_of_term (whd_betadeltaiota env t) with
+  match kind_of_term (whd_all env t) with
     | Prod (_,_,b) -> subst1 n b
     | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product")
 
@@ -761,48 +742,48 @@ let hnf_prod_applist env t nl =
 
 let dest_prod env =
   let rec decrec env m c =
-    let t = whd_betadeltaiota env c in
+    let t = whd_all env c in
     match kind_of_term t with
       | Prod (n,a,c0) ->
-          let d = (n,None,a) in
-	  decrec (push_rel d env) (add_rel_decl d m) c0
+	  let d = LocalAssum (n,a) in
+	  decrec (push_rel d env) (Context.Rel.add d m) c0
       | _ -> m,t
   in
-  decrec env empty_rel_context
+  decrec env Context.Rel.empty
 
 (* 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
+    let rty = whd_allnolet env ty in
     match kind_of_term rty with
     | Prod (x,t,c)  ->
-        let d = (x,None,t) in
-	prodec_rec (push_rel d env) (add_rel_decl d l) c
+        let d = LocalAssum (x,t) in
+	prodec_rec (push_rel d env) (Context.Rel.add d l) c
     | LetIn (x,b,t,c) ->
-        let d = (x,Some b,t) in
-	prodec_rec (push_rel d env) (add_rel_decl d l) c
+        let d = LocalDef (x,b,t) in
+	prodec_rec (push_rel d env) (Context.Rel.add d l) c
     | Cast (c,_,_)    -> prodec_rec env l c
     | _               ->
-      let rty' = whd_betadeltaiota env rty in
+      let rty' = whd_all 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
+  prodec_rec env Context.Rel.empty
 
 let dest_lam_assum env =
   let rec lamec_rec env l ty =
-    let rty = whd_betadeltaiota_nolet env ty in
+    let rty = whd_allnolet 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
+        let d = LocalAssum (x,t) in
+	lamec_rec (push_rel d env) (Context.Rel.add 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
+        let d = LocalDef (x,b,t) in
+	lamec_rec (push_rel d env) (Context.Rel.add d l) c
     | Cast (c,_,_)    -> lamec_rec env l c
     | _               -> l,rty
   in
-  lamec_rec env empty_rel_context
+  lamec_rec env Context.Rel.empty
 
 exception NotArity
 
diff --git a/kernel/reduction.mli b/kernel/reduction.mli
index 9a83ca70..8a2b2469 100644
--- a/kernel/reduction.mli
+++ b/kernel/reduction.mli
@@ -7,15 +7,16 @@
 (************************************************************************)
 
 open Term
-open Context
 open Environ
 
 (***********************************************************************
   s Reduction functions *)
 
+(* None of these functions do eta reduction *)
+
 val whd_betaiotazeta        : env -> constr -> constr
-val whd_betadeltaiota       : env -> constr -> constr
-val whd_betadeltaiota_nolet : env -> constr -> constr
+val whd_all                 : env -> constr -> constr
+val whd_allnolet : env -> constr -> constr
 
 val whd_betaiota     : env -> constr -> constr
 val nf_betaiota      : env -> constr -> constr
@@ -26,16 +27,16 @@ val nf_betaiota      : env -> constr -> constr
 exception NotConvertible
 exception NotConvertibleVect of int
 
-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 'a kernel_conversion_function = env -> 'a -> 'a -> unit
+type 'a extended_conversion_function = 
+  ?l2r:bool -> ?reds:Names.transparent_state -> env ->
+  ?evars:((existential->constr option) * UGraph.t) ->
+  'a -> 'a -> unit
 
 type conv_pb = CONV | CUMUL
 
 type 'a universe_compare = 
-  { (* Might raise NotConvertible *)
+  { (* Might raise NotConvertible or UnivInconsistency *)
     compare : env -> conv_pb -> sorts -> sorts -> 'a -> 'a;
     compare_instances: flex:bool -> 
 		       Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a;
@@ -45,7 +46,7 @@ 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
+type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.constraints
 
 val sort_cmp_universes : env -> conv_pb -> sorts -> sorts ->
   'a * 'a universe_compare -> 'a * 'a universe_compare
@@ -55,27 +56,15 @@ constructors. *)
 val convert_instances : flex:bool -> Univ.Instance.t -> Univ.Instance.t ->
   'a * 'a universe_compare -> 'a * 'a universe_compare
 
-val checked_universes : Univ.universes universe_compare
-val inferred_universes : (Univ.universes * Univ.Constraint.t) universe_compare
-
-val trans_conv_cmp       : ?l2r:bool -> conv_pb -> constr trans_conversion_function
-val trans_conv           :
-  ?l2r:bool -> ?evars:(existential->constr option) -> constr trans_conversion_function
-val trans_conv_leq       :
-  ?l2r:bool -> ?evars:(existential->constr option) -> types trans_conversion_function
+(** These two never raise UnivInconsistency, inferred_universes
+    just gathers the constraints. *)
+val checked_universes : UGraph.t universe_compare
+val inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare
 
-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
+(** These two functions can only raise NotConvertible *)
+val conv : constr extended_conversion_function
 
-val conv_cmp       : ?l2r:bool -> conv_pb -> constr conversion_function
-val conv           :
-  ?l2r:bool -> ?evars:(existential->constr option) -> constr conversion_function
-val conv_leq       :
-  ?l2r:bool -> ?evars:(existential->constr option) -> types conversion_function
-val conv_leq_vecti :
-  ?l2r:bool -> ?evars:(existential->constr option) -> types array conversion_function
+val conv_leq : types extended_conversion_function
 
 (** These conversion functions are used by module subtyping, which needs to infer
     universe constraints inside the kernel *)
@@ -84,36 +73,46 @@ val infer_conv : ?l2r:bool -> ?evars:(existential->constr option) ->
 val infer_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> 
   ?ts:Names.transparent_state -> types infer_conversion_function
 
+(** Depending on the universe state functions, this might raise
+  [UniverseInconsistency] in addition to [NotConvertible] (for better error
+  messages). *)
 val generic_conv : conv_pb -> l2r: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_vm_conv : (conv_pb -> types kernel_conversion_function) -> unit
+val vm_conv : conv_pb -> types kernel_conversion_function
 
-val default_conv     : conv_pb -> ?l2r:bool -> types conversion_function
-val default_conv_leq : ?l2r:bool -> types conversion_function
+val default_conv     : conv_pb -> ?l2r:bool -> types kernel_conversion_function
+val default_conv_leq : ?l2r:bool -> types kernel_conversion_function
 
 (************************************************************************)
 
 (** Builds an application node, reducing beta redexes it may produce. *)
+val beta_applist : constr -> constr list -> constr
+
+(** Builds an application node, reducing beta redexes it may produce. *)
 val beta_appvect : constr -> constr array -> constr
 
-(** Builds an application node, reducing the [n] first beta-zeta redexes. *)
-val betazeta_appvect : int -> constr -> constr array -> constr
+(** Builds an application node, reducing beta redexe it may produce. *)
+val beta_app : constr -> constr -> constr
 
 (** Pseudo-reduction rule  Prod(x,A,B) a --> B[x\a] *)
 val hnf_prod_applist : env -> types -> constr list -> types
 
+(** Compatibility alias for Term.lambda_appvect_assum *)
+val betazeta_appvect : int -> constr -> constr array -> constr
 
 (***********************************************************************
   s Recognizing products and arities modulo reduction *)
 
-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
+val dest_prod       : env -> types -> Context.Rel.t * types
+val dest_prod_assum : env -> types -> Context.Rel.t * types
+val dest_lam_assum  : env -> types -> Context.Rel.t * types
 
 exception NotArity
 
 val dest_arity : env -> types -> arity (* raises NotArity if not an arity *)
 val is_arity   : env -> types -> bool
+
+val warn_bytecode_compiler_failed : ?loc:Loc.t -> unit -> unit
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
index 4c326486..09f7bd75 100644
--- a/kernel/safe_typing.ml
+++ b/kernel/safe_typing.ml
@@ -60,6 +60,7 @@
 open Util
 open Names
 open Declarations
+open Context.Named.Declaration
 
 (** {6 Safe environments }
 
@@ -179,20 +180,17 @@ let set_engagement c senv =
     env = Environ.set_engagement c senv.env;
     engagement = Some c }
 
+let set_typing_flags c senv =
+  { senv with env = Environ.set_typing_flags c senv.env }
+
 (** Check that the engagement [c] expected by a library matches
     the current (initial) one *)
-let check_engagement env (expected_impredicative_set,expected_type_in_type) =
-  let impredicative_set,type_in_type = Environ.engagement env in
+let check_engagement env expected_impredicative_set =
+  let impredicative_set = Environ.engagement env in
   begin
     match impredicative_set, expected_impredicative_set with
     | PredicativeSet, ImpredicativeSet ->
-        Errors.error "Needs option -impredicative-set."
-    | _ -> ()
-  end;
-  begin
-    match type_in_type, expected_type_in_type with
-    | StratifiedType, TypeInType ->
-        Errors.error "Needs option -type-in-type."
+        CErrors.error "Needs option -impredicative-set."
     | _ -> ()
   end
 
@@ -222,20 +220,13 @@ let inline_private_constants_in_constr = Term_typing.inline_side_effects
 let inline_private_constants_in_definition_entry = Term_typing.inline_entry_side_effects
 let side_effects_of_private_constants x = Term_typing.uniq_seff (List.rev x)
 
-let constant_entry_of_private_constant = function
-  | { Entries.eff = Entries.SEsubproof (kn, cb, eff_env) } ->
-      [ kn, Term_typing.constant_entry_of_side_effect cb eff_env ]
-  | { Entries.eff = Entries.SEscheme (l,_) } ->
-      List.map (fun (_,kn,cb,eff_env) ->
-        kn, Term_typing.constant_entry_of_side_effect cb eff_env) l
-
 let private_con_of_con env c =
   let cbo = Environ.lookup_constant c env.env in
-  { Entries.from_env = Ephemeron.create env.revstruct;
+  { Entries.from_env = CEphemeron.create env.revstruct;
     Entries.eff      = Entries.SEsubproof (c,cbo,get_opaque_body env.env cbo) }
 
 let private_con_of_scheme ~kind env cl =
-  { Entries.from_env = Ephemeron.create env.revstruct;
+  { Entries.from_env = CEphemeron.create env.revstruct;
     Entries.eff      = Entries.SEscheme(
       List.map (fun (i,c) ->
         let cbo = Environ.lookup_constant c env.env in
@@ -353,10 +344,10 @@ let check_required current_libs needed =
     try
       let actual = DPMap.find id current_libs in
       if not(digest_match ~actual ~required) then
-        Errors.error
+        CErrors.error
           ("Inconsistent assumptions over module "^(DirPath.to_string id)^".")
     with Not_found ->
-      Errors.error ("Reference to unknown module "^(DirPath.to_string id)^".")
+      CErrors.error ("Reference to unknown module "^(DirPath.to_string id)^".")
   in
   Array.iter check needed
 
@@ -369,11 +360,12 @@ let check_required current_libs needed =
     hypothesis many many times, and the check performed here would
     cost too much. *)
 
-let safe_push_named (id,_,_ as d) env =
+let safe_push_named d env =
+  let id = get_id d in
   let _ =
     try
       let _ = Environ.lookup_named id env in
-      Errors.error ("Identifier "^Id.to_string id^" already defined.")
+      CErrors.error ("Identifier "^Id.to_string id^" already defined.")
     with Not_found -> () in
   Environ.push_named d env
 
@@ -390,13 +382,13 @@ let push_named_def (id,de) senv =
 	(Opaqueproof.force_constraints (Environ.opaque_tables senv.env) o)
     | _ -> assert false in
   let senv' = push_context_set poly univs senv in
-  let env'' = safe_push_named (id,Some c,typ) senv'.env in
+  let env'' = safe_push_named (LocalDef (id,c,typ)) senv'.env in
     univs, {senv' with env=env''}
 
 let push_named_assum ((id,t,poly),ctx) senv =
   let senv' = push_context_set poly 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
+  let env'' = safe_push_named (LocalAssum (id,t)) senv'.env in
     {senv' with env=env''}
 
 
@@ -561,6 +553,7 @@ let add_mind dir l mie senv =
 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 mtb = Declareops.hcons_module_body mtb in
   let senv' = add_field (l,SFBmodtype mtb) MT senv in
   mp, senv'
 
@@ -581,6 +574,7 @@ let full_add_module_type mp mt senv =
 let add_module l me inl senv =
   let mp = MPdot(senv.modpath, l) in
   let mb = Mod_typing.translate_module senv.env mp inl me in
+  let mb = Declareops.hcons_module_body mb in
   let senv' = add_field (l,SFBmodule mb) M senv in
   let senv'' =
     if Modops.is_functor mb.mod_type then senv'
@@ -821,8 +815,8 @@ 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)
+      let e = CErrors.push e in
+      CErrors.errorlabstrm "export" (CErrors.iprint e)
   in
   assert(senv.future_cst = []);
   let () = check_current_library dir senv in
@@ -857,6 +851,9 @@ let export ?except senv dir =
 let import lib cst vodigest senv =
   check_required senv.required lib.comp_deps;
   check_engagement senv.env lib.comp_enga;
+  if DirPath.equal (ModPath.dp senv.modpath) lib.comp_name then
+    CErrors.errorlabstrm "Safe_typing.import"
+     (Pp.strbrk "Cannot load a library with the same name as the current one.");
   let mp = MPfile lib.comp_name in
   let mb = lib.comp_mod in
   let env = Environ.push_context_set ~strict:true
@@ -906,7 +903,7 @@ 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";
+    CErrors.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
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
index 71dac321..15ebc7d8 100644
--- a/kernel/safe_typing.mli
+++ b/kernel/safe_typing.mli
@@ -132,6 +132,7 @@ val add_constraints :
 
 (** Setting the type theory flavor *)
 val set_engagement : Declarations.engagement -> safe_transformer0
+val set_typing_flags : Declarations.typing_flags -> safe_transformer0
 
 (** {6 Interactive module functions } *)
 
diff --git a/kernel/sorts.ml b/kernel/sorts.ml
index a9073688..62013b38 100644
--- a/kernel/sorts.ml
+++ b/kernel/sorts.ml
@@ -98,7 +98,7 @@ module Hsorts =
 	  let u' = huniv u in 
 	    if u' == u then c else Type u'
         | s -> s
-      let equal s1 s2 = match (s1,s2) with
+      let eq s1 s2 = match (s1,s2) with
         | (Prop c1, Prop c2) -> c1 == c2
         | (Type u1, Type u2) -> u1 == u2
         |_ -> false
diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml
index a422b18e..c8ceb064 100644
--- a/kernel/subtyping.ml
+++ b/kernel/subtyping.ml
@@ -110,7 +110,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
   in
   let u = 
     if poly then 
-      Errors.error ("Checking of subtyping of polymorphic" ^
+      CErrors.error ("Checking of subtyping of polymorphic" ^
 		       " inductive types not implemented")
     else Instance.empty
   in
@@ -317,7 +317,7 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
 		  (* 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
+		    if UGraph.check_constraints ctx1 (Environ.universes env) then
 		      cstrs, env, inst2
 		    else error (IncompatibleConstraints ctx1)
 		with Univ.UniverseInconsistency incon -> 
@@ -347,7 +347,7 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
 	      let c2 = Mod_subst.force_constr lc2 in
 	      check_conv NotConvertibleBodyField cst poly u infer_conv env' c1 c2))
    | IndType ((kn,i),mind1) ->
-       ignore (Errors.error (
+       ignore (CErrors.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 " ^
@@ -364,7 +364,7 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
       let error = NotConvertibleTypeField (env, arity1, typ2) in
        check_conv error cst false Univ.Instance.empty infer_conv_leq env arity1 typ2
    | IndConstr (((kn,i),j) as cstr,mind1) ->
-      ignore (Errors.error (
+      ignore (CErrors.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 " ^
diff --git a/kernel/term.ml b/kernel/term.ml
index ad8ae3be..15f187e5 100644
--- a/kernel/term.ml
+++ b/kernel/term.ml
@@ -8,9 +8,8 @@
 
 open Util
 open Pp
-open Errors
+open CErrors
 open Names
-open Context
 open Vars
 
 (**********************************************************************)
@@ -384,40 +383,46 @@ let mkNamedLambda id typ c = mkLambda (Name id, typ, subst_var id c)
 let mkNamedLetIn id c1 t c2 = mkLetIn (Name id, c1, t, subst_var id c2)
 
 (* Constructs either [(x:t)c] or [[x=b:t]c] *)
-let mkProd_or_LetIn (na,body,t) c =
-  match body with
-    | None -> mkProd (na, t, c)
-    | Some b -> mkLetIn (na, b, t, c)
-
-let mkNamedProd_or_LetIn (id,body,t) c =
-  match body with
-    | None -> mkNamedProd id t c
-    | Some b -> mkNamedLetIn id b t c
+let mkProd_or_LetIn decl c =
+  let open Context.Rel.Declaration in
+  match decl with
+  | LocalAssum (na,t) -> mkProd (na, t, c)
+  | LocalDef (na,b,t) -> mkLetIn (na, b, t, c)
+
+let mkNamedProd_or_LetIn decl c =
+  let open Context.Named.Declaration in
+  match decl with
+    | LocalAssum (id,t) -> mkNamedProd id t c
+    | LocalDef (id,b,t) -> mkNamedLetIn id b t c
 
 (* Constructs either [(x:t)c] or [c] where [x] is replaced by [b] *)
-let mkProd_wo_LetIn (na,body,t) c =
-  match body with
-    | None -> mkProd (na,  t, c)
-    | Some b -> subst1 b c
-
-let mkNamedProd_wo_LetIn (id,body,t) c =
-  match body with
-    | None -> mkNamedProd id t c
-    | Some b -> subst1 b (subst_var id c)
+let mkProd_wo_LetIn decl c =
+  let open Context.Rel.Declaration in
+  match decl with
+  | LocalAssum (na,t) -> mkProd (na, t, c)
+  | LocalDef (na,b,t) -> subst1 b c
+
+let mkNamedProd_wo_LetIn decl c =
+  let open Context.Named.Declaration in
+  match decl with
+    | LocalAssum (id,t) -> mkNamedProd id t c
+    | LocalDef (id,b,t) -> subst1 b (subst_var id c)
 
 (* non-dependent product t1 -> t2 *)
 let mkArrow t1 t2 = mkProd (Anonymous, t1, t2)
 
 (* Constructs either [[x:t]c] or [[x=b:t]c] *)
-let mkLambda_or_LetIn (na,body,t) c =
-  match body with
-    | None -> mkLambda (na, t, c)
-    | Some b -> mkLetIn (na, b, t, c)
-
-let mkNamedLambda_or_LetIn (id,body,t) c =
-  match body with
-    | None -> mkNamedLambda id t c
-    | Some b -> mkNamedLetIn id b t c
+let mkLambda_or_LetIn decl c =
+  let open Context.Rel.Declaration in
+  match decl with
+    | LocalAssum (na,t) -> mkLambda (na, t, c)
+    | LocalDef (na,b,t) -> mkLetIn (na, b, t, c)
+
+let mkNamedLambda_or_LetIn decl c =
+  let open Context.Named.Declaration in
+  match decl with
+    | LocalAssum (id,t) -> mkNamedLambda id t c
+    | LocalDef (id,b,t) -> mkNamedLetIn id b t c
 
 (* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *)
 let prodn n env b =
@@ -471,26 +476,58 @@ let rec to_prod n lam =
       | Cast (c,_,_) -> to_prod n c
       | _   -> errorlabstrm "to_prod" (mt ())
 
-(* pseudo-reduction rule:
- * [prod_app  s (Prod(_,B)) N --> B[N]
- * with an strip_outer_cast on the first argument to produce a product *)
+let it_mkProd_or_LetIn   = List.fold_left (fun c d -> mkProd_or_LetIn d c)
+let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c)
 
-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 ())
+(* Application with expected on-the-fly reduction *)
 
+let lambda_applist c l =
+  let rec app subst c l =
+    match kind_of_term c, l with
+    | Lambda(_,_,c), arg::l -> app (arg::subst) c l
+    | _, [] -> substl subst c
+    | _ -> anomaly (Pp.str "Not enough lambda's") in
+  app [] c l
 
-(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *)
-let prod_appvect t nL = Array.fold_left prod_app t nL
+let lambda_appvect c v = lambda_applist c (Array.to_list v)
+
+let lambda_applist_assum n c l =
+  let rec app n subst t l =
+    if Int.equal n 0 then
+      if l == [] then substl subst t
+      else anomaly (Pp.str "Not enough arguments")
+    else match kind_of_term t, l with
+    | Lambda(_,_,c), arg::l -> app (n-1) (arg::subst) c l
+    | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l
+    | _ -> anomaly (Pp.str "Not enough lambda/let's") in
+  app n [] c l
+
+let lambda_appvect_assum n c v = lambda_applist_assum n c (Array.to_list v)
 
 (* prod_applist T [ a1 ; ... ; an ] -> (T a1 ... an) *)
-let prod_applist t nL = List.fold_left prod_app t nL
+let prod_applist c l =
+  let rec app subst c l =
+    match kind_of_term c, l with
+    | Prod(_,_,c), arg::l -> app (arg::subst) c l
+    | _, [] -> substl subst c
+    | _ -> anomaly (Pp.str "Not enough prod's") in
+  app [] c l
 
-let it_mkProd_or_LetIn   = List.fold_left (fun c d -> mkProd_or_LetIn d c)
-let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c)
+(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *)
+let prod_appvect c v = prod_applist c (Array.to_list v)
+
+let prod_applist_assum n c l =
+  let rec app n subst t l =
+    if Int.equal n 0 then
+      if l == [] then substl subst t
+      else anomaly (Pp.str "Not enough arguments")
+    else match kind_of_term t, l with
+    | Prod(_,_,c), arg::l -> app (n-1) (arg::subst) c l
+    | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l
+    | _ -> anomaly (Pp.str "Not enough prod/let's") in
+  app n [] c l
+
+let prod_appvect_assum n c v = prod_applist_assum n c (Array.to_list v)
 
 (*********************************)
 (* Other term destructors        *)
@@ -545,26 +582,28 @@ let decompose_lam_n n =
 (* Transforms a product term (x1:T1)..(xn:Tn)T into the pair
    ([(xn,Tn);...;(x1,T1)],T), where T is not a product *)
 let decompose_prod_assum =
+  let open Context.Rel.Declaration in
   let rec prodec_rec l c =
     match kind_of_term c with
-    | Prod (x,t,c)    -> prodec_rec (add_rel_decl (x,None,t) l) c
-    | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) c
+    | Prod (x,t,c)    -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) c
+    | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) c
     | Cast (c,_,_)      -> prodec_rec l c
     | _               -> l,c
   in
-  prodec_rec empty_rel_context
+  prodec_rec Context.Rel.empty
 
 (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair
    ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *)
 let decompose_lam_assum =
   let rec lamdec_rec l c =
+    let open Context.Rel.Declaration in
     match kind_of_term c with
-    | Lambda (x,t,c)  -> lamdec_rec (add_rel_decl (x,None,t) l) c
-    | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) c
+    | Lambda (x,t,c)  -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) c
+    | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) c
     | Cast (c,_,_)      -> lamdec_rec l c
     | _               -> l,c
   in
-  lamdec_rec empty_rel_context
+  lamdec_rec Context.Rel.empty
 
 (* Given a positive integer n, decompose a product or let-in term
    of the form [forall (x1:T1)..(xi:=ci:Ti)..(xn:Tn), T] into the pair
@@ -575,13 +614,15 @@ let decompose_prod_n_assum n =
     error "decompose_prod_n_assum: integer parameter must be positive";
   let rec prodec_rec l n 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
-    | Cast (c,_,_)      -> prodec_rec l n c
-    | c -> error "decompose_prod_n_assum: not enough assumptions"
+    else
+      let open Context.Rel.Declaration in
+      match kind_of_term c with
+      | Prod (x,t,c)    -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c
+      | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c
+      | Cast (c,_,_)      -> prodec_rec l n c
+      | c -> error "decompose_prod_n_assum: not enough assumptions"
   in
-  prodec_rec empty_rel_context n
+  prodec_rec Context.Rel.empty n
 
 (* Given a positive integer n, decompose a lambda or let-in term [fun
    (x1:T1)..(xi:=ci:Ti)..(xn:Tn) => T] into the pair of the abstracted
@@ -594,13 +635,15 @@ let decompose_lam_n_assum n =
     error "decompose_lam_n_assum: integer parameter must be positive";
   let rec lamdec_rec l n 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
-    | Cast (c,_,_)      -> lamdec_rec l n c
-    | c -> error "decompose_lam_n_assum: not enough abstractions"
+    else
+      let open Context.Rel.Declaration in
+      match kind_of_term c with
+      | Lambda (x,t,c)  -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c
+      | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) n c
+      | Cast (c,_,_)      -> lamdec_rec l n c
+      | c -> error "decompose_lam_n_assum: not enough abstractions"
   in
-  lamdec_rec empty_rel_context n
+  lamdec_rec Context.Rel.empty n
 
 (* Same, counting let-in *)
 let decompose_lam_n_decls n =
@@ -608,32 +651,15 @@ let decompose_lam_n_decls n =
     error "decompose_lam_n_decls: integer parameter must be positive";
   let rec lamdec_rec l n 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-1) c
-    | Cast (c,_,_)      -> lamdec_rec l n c
-    | c -> error "decompose_lam_n_decls: not enough abstractions"
-  in
-  lamdec_rec empty_rel_context n
-
-(* (nb_lam [na1:T1]...[nan:Tan]c) where c is not an abstraction
- * gives n (casts are ignored) *)
-let nb_lam =
-  let rec nbrec n c = match kind_of_term c with
-    | Lambda (_,_,c) -> nbrec (n+1) c
-    | Cast (c,_,_) -> nbrec n c
-    | _ -> n
-  in
-  nbrec 0
-
-(* similar to nb_lam, but gives the number of products instead *)
-let nb_prod =
-  let rec nbrec n c = match kind_of_term c with
-    | Prod (_,_,c) -> nbrec (n+1) c
-    | Cast (c,_,_) -> nbrec n c
-    | _ -> n
+    else
+      let open Context.Rel.Declaration in
+      match kind_of_term c with
+      | Lambda (x,t,c)  -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c
+      | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c
+      | Cast (c,_,_)      -> lamdec_rec l n c
+      | c -> error "decompose_lam_n_decls: not enough abstractions"
   in
-  nbrec 0
+  lamdec_rec Context.Rel.empty n
 
 let prod_assum t = fst (decompose_prod_assum t)
 let prod_n_assum n t = fst (decompose_prod_n_assum n t)
@@ -654,13 +680,14 @@ let strip_lam_n n t = snd (decompose_lam_n n t)
    Such a term can canonically be seen as the pair of a context of types
    and of a sort *)
 
-type arity = rel_context * sorts
+type arity = Context.Rel.t * sorts
 
 let destArity =
+  let open Context.Rel.Declaration in
   let rec prodec_rec l c =
     match kind_of_term c with
-    | Prod (x,t,c)    -> prodec_rec ((x,None,t)::l) c
-    | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c
+    | Prod (x,t,c)    -> prodec_rec (LocalAssum (x,t) :: l) c
+    | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) c
     | Cast (c,_,_)      -> prodec_rec l c
     | Sort s          -> l,s
     | _               -> anomaly ~label:"destArity" (Pp.str "not an arity")
diff --git a/kernel/term.mli b/kernel/term.mli
index 14c20a20..60a3c771 100644
--- a/kernel/term.mli
+++ b/kernel/term.mli
@@ -7,7 +7,6 @@
 (************************************************************************)
 
 open Names
-open Context
 
 (** {5 Redeclaration of types from module Constr and Sorts}
 
@@ -203,7 +202,7 @@ val destCoFix : constr -> cofixpoint
 
 (** 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))]
+   Eg: in context [A:Prop], [A->A] is built by [(mkArrow (mkRel 1) (mkRel 2))]
 *)
 val mkArrow : types -> types -> constr
 
@@ -213,14 +212,14 @@ 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
-val mkProd_wo_LetIn : rel_declaration -> types -> types
-val mkNamedProd_or_LetIn : named_declaration -> types -> types
-val mkNamedProd_wo_LetIn : named_declaration -> types -> types
+val mkProd_or_LetIn : Context.Rel.Declaration.t -> types -> types
+val mkProd_wo_LetIn : Context.Rel.Declaration.t -> types -> types
+val mkNamedProd_or_LetIn : Context.Named.Declaration.t -> types -> types
+val mkNamedProd_wo_LetIn : Context.Named.Declaration.t -> types -> types
 
 (** Constructs either [[x:t]c] or [[x=b:t]c] *)
-val mkLambda_or_LetIn : rel_declaration -> constr -> constr
-val mkNamedLambda_or_LetIn : named_declaration -> constr -> constr
+val mkLambda_or_LetIn : Context.Rel.Declaration.t -> constr -> constr
+val mkNamedLambda_or_LetIn : Context.Named.Declaration.t -> constr -> constr
 
 (** {5 Other term constructors. } *)
 
@@ -262,14 +261,34 @@ val to_lambda : int -> constr -> constr
    where [l] is [fun (x_1:T_1)...(x_n:T_n) => T] *)
 val to_prod : int -> constr -> constr
 
+val it_mkLambda_or_LetIn : constr -> Context.Rel.t -> constr
+val it_mkProd_or_LetIn : types -> Context.Rel.t -> types
+
+(** In [lambda_applist c args], [c] is supposed to have the form
+    [λΓ.c] with [Γ] without let-in; it returns [c] with the variables
+    of [Γ] instantiated by [args]. *)
+val lambda_applist : constr -> constr list -> constr
+val lambda_appvect : constr -> constr array -> constr
+
+(** In [lambda_applist_assum n c args], [c] is supposed to have the
+    form [λΓ.c] with [Γ] of length [m] and possibly with let-ins; it
+    returns [c] with the assumptions of [Γ] instantiated by [args] and
+    the local definitions of [Γ] expanded. *)
+val lambda_applist_assum : int -> constr -> constr list -> constr
+val lambda_appvect_assum : int -> constr -> constr array -> constr
+
 (** pseudo-reduction rule *)
 
 (** [prod_appvect] [forall (x1:B1;...;xn:Bn), B] [a1...an] @return [B[a1...an]] *)
 val prod_appvect : constr -> constr array -> constr
 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
+(** In [prod_appvect_assum n c args], [c] is supposed to have the
+    form [∀Γ.c] with [Γ] of length [m] and possibly with let-ins; it
+    returns [c] with the assumptions of [Γ] instantiated by [args] and
+    the local definitions of [Γ] expanded. *)
+val prod_appvect_assum : int -> constr -> constr array -> constr
+val prod_applist_assum : int -> constr -> constr list -> constr
 
 (** {5 Other term destructors. } *)
 
@@ -294,36 +313,29 @@ 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 *)
-val decompose_prod_assum : types -> rel_context * types
+val decompose_prod_assum : types -> Context.Rel.t * types
 
-(** Idem with lambda's *)
-val decompose_lam_assum : constr -> rel_context * constr
+(** Idem with lambda's and let's *)
+val decompose_lam_assum : constr -> Context.Rel.t * constr
 
 (** Idem but extract the first [n] premisses, counting let-ins. *)
-val decompose_prod_n_assum : int -> types -> rel_context * types
+val decompose_prod_n_assum : int -> types -> Context.Rel.t * types
 
 (** Idem for lambdas, _not_ counting let-ins *)
-val decompose_lam_n_assum : int -> constr -> rel_context * constr
+val decompose_lam_n_assum : int -> constr -> Context.Rel.t * constr
 
 (** Idem, counting let-ins *)
-val decompose_lam_n_decls : int -> constr -> rel_context * constr
-
-(** [nb_lam] {% $ %}[x_1:T_1]...[x_n:T_n]c{% $ %} where {% $ %}c{% $ %} is not an abstraction
-   gives {% $ %}n{% $ %} (casts are ignored) *)
-val nb_lam : constr -> int
-
-(** Similar to [nb_lam], but gives the number of products instead *)
-val nb_prod : constr -> int
+val decompose_lam_n_decls : int -> constr -> Context.Rel.t * constr
 
 (** Return the premisses/parameters of a type/term (let-in included) *)
-val prod_assum : types -> rel_context
-val lam_assum : constr -> rel_context
+val prod_assum : types -> Context.Rel.t
+val lam_assum : constr -> Context.Rel.t
 
 (** Return the first n-th premisses/parameters of a type (let included and counted) *)
-val prod_n_assum : int -> types -> rel_context
+val prod_n_assum : int -> types -> Context.Rel.t
 
 (** Return the first n-th premisses/parameters of a term (let included but not counted) *)
-val lam_n_assum : int -> constr -> rel_context
+val lam_n_assum : int -> constr -> Context.Rel.t
 
 (** Remove the premisses/parameters of a type/term *)
 val strip_prod : types -> types
@@ -356,7 +368,7 @@ val under_outer_cast : (constr -> constr) -> constr -> constr
     Such a term can canonically be seen as the pair of a context of types
     and of a sort *)
 
-type arity = rel_context * sorts
+type arity = Context.Rel.t * sorts
 
 (** Build an "arity" from its canonical form *)
 val mkArity : arity -> types
@@ -436,11 +448,11 @@ val eq_constr : constr -> constr -> bool
 
 (** [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
+val eq_constr_univs : constr UGraph.check_function
 
 (** [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
+val leq_constr_univs : constr UGraph.check_function
 
 (** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts,
    application grouping and ignoring universe instances. *)
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
index 510f4354..749b5dba 100644
--- a/kernel/term_typing.ml
+++ b/kernel/term_typing.ml
@@ -12,11 +12,10 @@
 (* This module provides the main entry points for type-checking basic
    declarations *)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Term
-open Context
 open Declarations
 open Environ
 open Entries
@@ -126,29 +125,30 @@ let check_signatures curmb sl =
     | None -> None, None
     | Some curmb ->
         try
-          let mb = Ephemeron.get mb in
+          let mb = CEphemeron.get mb in
           match sl with
           | None -> sl, None
           | Some n ->
               if List.length mb >= how_many && CList.skipn how_many mb == curmb
               then Some (n + how_many), Some mb
               else None, None
-        with Ephemeron.InvalidKey -> None, None in
+        with CEphemeron.InvalidKey -> None, None in
   let sl, _ = List.fold_left is_direct_ancestor (Some 0,Some curmb) sl in
   sl
 
 let skip_trusted_seff sl b e =
   let rec aux sl b e acc =
+    let open Context.Rel.Declaration in
     match sl, kind_of_term b with
     | (None|Some 0), _ -> b, e, acc
     | Some sl, LetIn (n,c,ty,bo) ->
        aux (Some (sl-1)) bo
-         (Environ.push_rel (n,Some c,ty) e) (`Let(n,c,ty)::acc)
+         (Environ.push_rel (LocalDef (n,c,ty)) e) (`Let(n,c,ty)::acc)
     | Some sl, App(hd,arg) ->
        begin match kind_of_term hd with
        | Lambda (n,ty,bo) ->
            aux (Some (sl-1)) bo
-             (Environ.push_rel (n,None,ty) e) (`Cut(n,ty,arg)::acc)
+             (Environ.push_rel (LocalAssum (n,ty)) e) (`Cut(n,ty,arg)::acc)
        | _ -> assert false
        end
     | _ -> assert false
@@ -167,8 +167,10 @@ let hcons_j j =
   { uj_val = hcons_constr j.uj_val; uj_type = hcons_constr j.uj_type} 
 
 let feedback_completion_typecheck =
-  Option.iter (fun state_id -> Pp.feedback ~state_id Feedback.Complete)
-	      
+  let open Feedback in
+  Option.iter (fun state_id ->
+      feedback ~id:(State state_id) Feedback.Complete)
+
 let infer_declaration ~trust env kn dcl =
   match dcl with
   | ParameterEntry (ctx,poly,(t,uctx),nl) ->
@@ -246,17 +248,19 @@ let infer_declaration ~trust env kn dcl =
 let global_vars_set_constant_type env = function
   | RegularArity t -> global_vars_set env t
   | TemplateArity (ctx,_) ->
-      Context.fold_rel_context
-        (fold_rel_declaration
+      Context.Rel.fold_outside
+        (Context.Rel.Declaration.fold
 	  (fun t c -> Id.Set.union (global_vars_set env t) c))
       ctx ~init:Id.Set.empty
 
 let record_aux env s_ty s_bo suggested_expr =
+  let open Context.Named.Declaration in
   let in_ty = keep_hyps env s_ty in
   let v =
     String.concat " "
-      (CList.map_filter (fun (id, _,_) ->
-          if List.exists (fun (id',_,_) -> Id.equal id id') in_ty then None
+      (CList.map_filter (fun decl ->
+          let id = get_id decl in
+          if List.exists (Id.equal id % get_id) in_ty then None
           else Some (Id.to_string id))
         (keep_hyps env s_bo)) in
   Aux_file.record_in_aux "context_used" (v ^ ";" ^ suggested_expr)
@@ -265,8 +269,9 @@ 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 open Context.Named.Declaration in
   let check declared inferred =
-    let mk_set l = List.fold_right Id.Set.add (List.map pi1 l) Id.Set.empty in
+    let mk_set l = List.fold_right Id.Set.add (List.map get_id l) Id.Set.empty in
     let inferred_set, declared_set = mk_set inferred, mk_set declared in
     if not (Id.Set.subset inferred_set declared_set) then
       let l = Id.Set.elements (Idset.diff inferred_set declared_set) in
@@ -277,12 +282,13 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx)
         str " used but not declared:" ++
         fnl () ++ pr_sequence Id.print (List.rev l) ++ str ".")) in
   let sort evn l =
-    List.filter (fun (id,_,_) ->
-      List.exists (fun (id',_,_) -> Names.Id.equal id id') l)
+    List.filter (fun decl ->
+      let id = get_id decl in
+      List.exists (Names.Id.equal id % get_id) l)
     (named_context env) in
   (* We try to postpone the computation of used section variables *)
   let hyps, def =
-    let context_ids = List.map pi1 (named_context env) in
+    let context_ids = List.map get_id (named_context env) in
     match ctx with
     | None when not (List.is_empty context_ids) -> 
         (* No declared section vars, and non-empty section context:
@@ -346,7 +352,9 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx)
 	    const_body_code = None;
 	    const_polymorphic = poly;
 	    const_universes = univs;
-	    const_inline_code = inline_code }
+	    const_inline_code = inline_code;
+	    const_typing_flags = Environ.typing_flags env;
+	    }
 	in
 	let env = add_constant kn cb env in
 	compile_constant_body env comp_univs def
@@ -359,7 +367,8 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx)
     const_body_code = tps;
     const_polymorphic = poly;
     const_universes = univs;
-    const_inline_code = inline_code }
+    const_inline_code = inline_code;
+    const_typing_flags = Environ.typing_flags env }
 
 (*s Global and local constant declaration. *)
 
@@ -473,7 +482,8 @@ let translate_local_def mb env id centry =
     | Undef _ -> ()
     | Def _ -> ()
     | OpaqueDef lc ->
-       let context_ids = List.map pi1 (named_context env) in
+       let open Context.Named.Declaration in
+       let context_ids = List.map get_id (named_context env) in
        let ids_typ = global_vars_set env typ in
        let ids_def = global_vars_set env
          (Opaqueproof.force_proof (opaque_tables env) lc) in
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index f7f5e507..0059111c 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -6,19 +6,19 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Univ
 open Term
 open Vars
-open Context
 open Declarations
 open Environ
 open Entries
 open Reduction
 open Inductive
 open Type_errors
+open Context.Rel.Declaration
 
 let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y
 
@@ -37,7 +37,7 @@ let check_constraints cst env =
 
 (* 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
+  match kind_of_term(whd_all env j.uj_type) with
     | Sort s -> {utj_val = j.uj_val; utj_type = s }
     | _ -> error_not_type env j
 
@@ -79,7 +79,7 @@ let judge_of_type u =
 
 let judge_of_relative env n =
   try
-    let (_,_,typ) = lookup_rel n env in
+    let typ = get_type (lookup_rel n env) in
     { uj_val  = mkRel n;
       uj_type = lift n typ }
   with Not_found ->
@@ -99,18 +99,20 @@ let judge_of_variable env id =
    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) () ->
+  Context.Named.fold_outside
+    (fun d1 () ->
+      let open Context.Named.Declaration in
+      let id = get_id d1 in
       try
-        let (_,b2,ty2) = lookup_named id env in
-        conv env ty2 ty1;
-        (match b2,b1 with
-        | None, None -> ()
-        | None, Some _ ->
+        let d2 = lookup_named id env in
+        conv env (get_type d2) (get_type d1);
+        (match d2,d1 with
+        | LocalAssum _, LocalAssum _ -> ()
+        | LocalAssum _, LocalDef _ ->
             (* 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);
+        | LocalDef _, LocalAssum _ -> raise NotConvertible
+        | LocalDef (_,b2,_), LocalDef (_,b1,_) -> conv env b2 b1);
       with Not_found | NotConvertible | Option.Heterogeneous ->
         error_reference_variables env id c)
     sign
@@ -125,9 +127,9 @@ let extract_level env p =
   match kind_of_term c with Sort (Type u) -> Univ.Universe.level u | _ -> None
 
 let extract_context_levels env l =
-  let fold l (_, b, p) = match b with
-  | None -> extract_level env p :: l
-  | _ -> l
+  let fold l = function
+    | LocalAssum (_,p) -> extract_level env p :: l
+    | LocalDef _ -> l
   in
   List.fold_left fold [] l
 
@@ -135,7 +137,7 @@ 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) ->
-     let ind, l = decompose_app (whd_betadeltaiota env c) in
+     let ind, l = decompose_app (whd_all env c) in
      if isInd ind && List.is_empty l then
        let mis = lookup_mind_specif env (fst (destInd ind)) in
        let nparams = Inductive.inductive_params mis in
@@ -231,7 +233,7 @@ let judge_of_apply env funj argjv =
 	{ uj_val  = mkApp (j_val funj, Array.map j_val argjv);
           uj_type = typ }
     | hj::restjl ->
-        (match kind_of_term (whd_betadeltaiota env typ) with
+        (match kind_of_term (whd_all env typ) with
           | Prod (_,c1,c2) ->
 	      (try
 		 let () = conv_leq false env hj.uj_type c1 in
@@ -459,13 +461,13 @@ let rec execute env cstr =
 
     | Lambda (name,c1,c2) ->
       let varj = execute_type env c1 in
-      let env1 = push_rel (name,None,varj.utj_val) env in
+      let env1 = push_rel (LocalAssum (name,varj.utj_val)) env in
       let j' = execute env1 c2 in
         judge_of_abstraction env name varj j'
 
     | Prod (name,c1,c2) ->
       let varj = execute_type env c1 in
-      let env1 = push_rel (name,None,varj.utj_val) env in
+      let env1 = push_rel (LocalAssum (name,varj.utj_val)) env in
       let varj' = execute_type env1 c2 in
 	judge_of_product env name varj varj'
 
@@ -473,7 +475,7 @@ let rec execute env cstr =
       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 env1 = push_rel (LocalDef (name,j1.uj_val,j2.utj_val)) env in
       let j' = execute env1 c3 in
         judge_of_letin env name j1 j2 j'
 
@@ -549,18 +551,18 @@ let infer_v env cv =
 (* Typing of several terms. *)
 
 let infer_local_decl env id = function
-  | LocalDef c ->
+  | LocalDefEntry c ->
       let j = infer env c in
-      (Name id, Some j.uj_val, j.uj_type)
-  | LocalAssum c ->
+      LocalDef (Name id, j.uj_val, j.uj_type)
+  | LocalAssumEntry c ->
       let j = infer env c in
-      (Name id, None, assumption_of_judgment env j)
+      LocalAssum (Name id, assumption_of_judgment env j)
 
 let infer_local_decls env decls =
   let rec inferec env = function
   | (id, d) :: l ->
       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
+	(push_rel d env, Context.Rel.add d l)
+  | [] -> (env, Context.Rel.empty) in
   inferec env decls
diff --git a/kernel/typeops.mli b/kernel/typeops.mli
index 2c6ca1fe..2112284e 100644
--- a/kernel/typeops.mli
+++ b/kernel/typeops.mli
@@ -9,7 +9,6 @@
 open Names
 open Univ
 open Term
-open Context
 open Environ
 open Entries
 open Declarations
@@ -28,7 +27,7 @@ val infer_v    : env -> constr array -> unsafe_judgment array
 val infer_type : env -> types        -> unsafe_type_judgment
 
 val infer_local_decls :
-  env -> (Id.t * local_entry) list -> (env * rel_context)
+  env -> (Id.t * local_entry) list -> (env * Context.Rel.t)
 
 (** {6 Basic operations of the typing machine. } *)
 
@@ -128,4 +127,4 @@ 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
+val check_hyps_inclusion : env -> constr -> Context.section_context -> unit
diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml
new file mode 100644
index 00000000..4884d0de
--- /dev/null
+++ b/kernel/uGraph.ml
@@ -0,0 +1,898 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - 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 Univ
+
+(* 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] *)
+(* Support for universe polymorphism by MS [2014] *)
+
+(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu
+   Sozeau, Pierre-Marie Pédrot, Jacques-Henri Jourdan *)
+
+let error_inconsistency o u v (p:explanation option) =
+  raise (UniverseInconsistency (o,Universe.make u,Universe.make v,p))
+
+(* 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.
+
+   We use the algorithm described in the paper:
+
+   Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A
+   new approach to incremental cycle detection and related
+   problems. arXiv preprint arXiv:1112.0784.
+
+ *)
+
+open Universe
+
+module UMap = LMap
+
+type status = NoMark | Visited | WeakVisited | ToMerge
+
+(* Comparison on this type is pointer equality *)
+type canonical_node =
+    { univ: Level.t;
+      ltle: bool UMap.t;  (* true: strict (lt) constraint.
+                             false: weak  (le) constraint. *)
+      gtge: LSet.t;
+      rank : int;
+      klvl: int;
+      ilvl: int;
+      mutable status: status
+    }
+
+let big_rank = 1000000
+
+(* 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_node
+  | Equiv of Level.t
+
+type universes =
+  { entries : univ_entry UMap.t;
+    index : int;
+    n_nodes : int; n_edges : int }
+
+type t = universes
+
+(** 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 _ n = match n with
+  | Equiv _ -> ()
+  | Canonical n -> n.status <- NoMark
+  in
+  UMap.iter iter g.entries
+
+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
+
+(* Every Level.t has a unique canonical arc representative *)
+
+(* Low-level function : makes u an alias for v.
+   Does not removes edges from n_edges, but decrements n_nodes.
+   u should be entered as canonical before.  *)
+let enter_equiv g u v =
+  { entries =
+      UMap.modify u (fun _ a ->
+        match a with
+        | Canonical n ->
+          n.status <- NoMark;
+          Equiv v
+        | _ -> assert false) g.entries;
+    index = g.index;
+    n_nodes = g.n_nodes - 1;
+    n_edges = g.n_edges }
+
+(* Low-level function : changes data associated with a canonical node.
+   Resets the mutable fields in the old record, in order to avoid breaking
+   invariants for other users of this record.
+   n.univ should already been inserted as a canonical node. *)
+let change_node g n =
+  { g with entries =
+      UMap.modify n.univ
+        (fun _ a ->
+          match a with
+          | Canonical n' ->
+            n'.status <- NoMark;
+            Canonical n
+          | _ -> assert false)
+        g.entries }
+
+(* repr : universes -> Level.t -> canonical_node *)
+(* canonical representative : we follow the Equiv links *)
+let rec repr g u =
+  let a =
+    try UMap.find u g.entries
+    with Not_found -> CErrors.anomaly ~label:"Univ.repr"
+        (str"Universe " ++ Level.pr u ++ str" undefined")
+  in
+  match a with
+    | Equiv v -> repr g v
+    | Canonical arc -> arc
+
+let get_set_arc g = repr g Level.set
+let is_set_arc u = Level.is_set u.univ
+let is_prop_arc u = Level.is_prop u.univ
+
+exception AlreadyDeclared
+
+(* Reindexes the given universe, using the next available index. *)
+let use_index g u =
+  let u = repr g u in
+  let g = change_node g { u with ilvl = g.index } in
+  assert (g.index > min_int);
+  { g with index = g.index - 1 }
+
+(* [safe_repr] is like [repr] but if the graph doesn't contain the
+   searched universe, we add it. *)
+let safe_repr g u =
+  let rec safe_repr_rec entries u =
+    match UMap.find u entries with
+    | Equiv v -> safe_repr_rec entries v
+    | Canonical arc -> arc
+  in
+  try g, safe_repr_rec g.entries u
+  with Not_found ->
+    let can =
+      { univ = u;
+        ltle = UMap.empty; gtge = LSet.empty;
+        rank = if Level.is_small u then big_rank else 0;
+        klvl = 0; ilvl = 0;
+        status = NoMark }
+    in
+    let g = { g with
+      entries = UMap.add u (Canonical can) g.entries;
+      n_nodes = g.n_nodes + 1 }
+    in
+    let g = use_index g u in
+    g, repr g u
+
+(* Returns 1 if u is higher than v in topological order.
+           -1        lower
+           0 if u = v *)
+let topo_compare u v =
+  if u.klvl > v.klvl then 1
+  else if u.klvl < v.klvl then -1
+  else if u.ilvl > v.ilvl then 1
+  else if u.ilvl < v.ilvl then -1
+  else (assert (u==v); 0)
+
+(* Checks most of the invariants of the graph. For debugging purposes. *)
+let check_universes_invariants g =
+  let n_edges = ref 0 in
+  let n_nodes = ref 0 in
+  UMap.iter (fun l u ->
+    match u with
+    | Canonical u ->
+      UMap.iter (fun v strict ->
+          incr n_edges;
+          let v = repr g v in
+          assert (topo_compare u v = -1);
+          if u.klvl = v.klvl then
+            assert (LSet.mem u.univ v.gtge ||
+                    LSet.exists (fun l -> u == repr g l) v.gtge))
+        u.ltle;
+      LSet.iter (fun v ->
+        let v = repr g v in
+        assert (v.klvl = u.klvl &&
+            (UMap.mem u.univ v.ltle ||
+             UMap.exists (fun l _ -> u == repr g l) v.ltle))
+      ) u.gtge;
+      assert (u.status = NoMark);
+      assert (Level.equal l u.univ);
+      assert (u.ilvl > g.index);
+      assert (not (UMap.mem u.univ u.ltle));
+      incr n_nodes
+    | Equiv _ -> assert (not (Level.is_small l)))
+    g.entries;
+  assert (!n_edges = g.n_edges);
+  assert (!n_nodes = g.n_nodes)
+
+let clean_ltle g ltle =
+  UMap.fold (fun u strict acc ->
+      let uu = (repr g u).univ in
+      if Level.equal uu u then acc
+      else (
+        let acc = UMap.remove u (fst acc) in
+        if not strict && UMap.mem uu acc then (acc, true)
+        else (UMap.add uu strict acc, true)))
+    ltle (ltle, false)
+
+let clean_gtge g gtge =
+  LSet.fold (fun u acc ->
+      let uu = (repr g u).univ in
+      if Level.equal uu u then acc
+      else LSet.add uu (LSet.remove u (fst acc)), true)
+    gtge (gtge, false)
+
+(* [get_ltle] and [get_gtge] return ltle and gtge arcs.
+   Moreover, if one of these lists is dirty (e.g. points to a
+   non-canonical node), these functions clean this node in the
+   graph by removing some duplicate edges *)
+let get_ltle g u =
+  let ltle, chgt_ltle = clean_ltle g u.ltle in
+  if not chgt_ltle then u.ltle, u, g
+  else
+    let sz = UMap.cardinal u.ltle in
+    let sz2 = UMap.cardinal ltle in
+    let u = { u with ltle } in
+    let g = change_node g u in
+    let g = { g with n_edges = g.n_edges + sz2 - sz } in
+    u.ltle, u, g
+
+let get_gtge g u =
+  let gtge, chgt_gtge = clean_gtge g u.gtge in
+  if not chgt_gtge then u.gtge, u, g
+  else
+    let u = { u with gtge } in
+    let g = change_node g u in
+    u.gtge, u, g
+
+(* [revert_graph] rollbacks the changes made to mutable fields in
+   nodes in the graph.
+   [to_revert] contains the touched nodes. *)
+let revert_graph to_revert g =
+  List.iter (fun t ->
+    match UMap.find t g.entries with
+    | Equiv _ -> ()
+    | Canonical t ->
+      t.status <- NoMark) to_revert
+
+exception AbortBackward of universes
+exception CycleDetected
+
+(* Implementation of the algorithm described in § 5.1 of the following paper:
+
+   Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A
+   new approach to incremental cycle detection and related
+   problems. arXiv preprint arXiv:1112.0784.
+
+   The "STEP X" comments contained in this file refers to the
+   corresponding step numbers of the algorithm described in Section
+   5.1 of this paper.  *)
+
+(* [delta] is the timeout for backward search. It might be
+    useful to tune a multiplicative constant. *)
+let get_delta g =
+  int_of_float
+    (min (float_of_int g.n_edges ** 0.5)
+        (float_of_int g.n_nodes ** (2./.3.)))
+
+let rec backward_traverse to_revert b_traversed count g x =
+  let x = repr g x in
+  let count = count - 1 in
+  if count < 0 then begin
+    revert_graph to_revert g;
+    raise (AbortBackward g)
+  end;
+  if x.status = NoMark then begin
+    x.status <- Visited;
+    let to_revert = x.univ::to_revert in
+    let gtge, x, g = get_gtge g x in
+    let to_revert, b_traversed, count, g =
+      LSet.fold (fun y (to_revert, b_traversed, count, g) ->
+        backward_traverse to_revert b_traversed count g y)
+        gtge (to_revert, b_traversed, count, g)
+    in
+    to_revert, x.univ::b_traversed, count, g
+  end
+  else to_revert, b_traversed, count, g
+
+let rec forward_traverse f_traversed g v_klvl x y =
+  let y = repr g y in
+  if y.klvl < v_klvl then begin
+    let y = { y with klvl = v_klvl;
+                      gtge = if x == y then LSet.empty
+                            else LSet.singleton x.univ }
+    in
+    let g = change_node g y in
+    let ltle, y, g = get_ltle g y in
+    let f_traversed, g =
+      UMap.fold (fun z _ (f_traversed, g) ->
+        forward_traverse f_traversed g v_klvl y z)
+      ltle (f_traversed, g)
+    in
+    y.univ::f_traversed, g
+    end else if y.klvl = v_klvl && x != y then
+      let g = change_node g
+        { y with gtge = LSet.add x.univ y.gtge } in
+      f_traversed, g
+    else f_traversed, g
+
+let rec find_to_merge to_revert g x v =
+  let x = repr g x in
+  match x.status with
+  | Visited -> false, to_revert   | ToMerge -> true, to_revert
+  | NoMark ->
+    let to_revert = x::to_revert in
+    if Level.equal x.univ v then
+      begin x.status <- ToMerge; true, to_revert end
+    else
+      begin
+        let merge, to_revert = LSet.fold
+          (fun y (merge, to_revert) ->
+            let merge', to_revert = find_to_merge to_revert g y v in
+            merge' || merge, to_revert) x.gtge (false, to_revert)
+        in
+        x.status <- if merge then ToMerge else Visited;
+        merge, to_revert
+      end
+  | _ -> assert false
+
+let get_new_edges g to_merge =
+  (* Computing edge sets. *)
+  let to_merge_lvl =
+    List.fold_left (fun acc u -> UMap.add u.univ u acc)
+      UMap.empty to_merge
+  in
+  let ltle =
+    UMap.fold (fun _ n acc ->
+      UMap.merge (fun _ strict1 strict2 ->
+        match strict1, strict2 with
+        | Some true, _ | _, Some true -> Some true
+        | _, _ -> Some false)
+        acc n.ltle)
+      to_merge_lvl UMap.empty
+  in
+  let ltle, _ = clean_ltle g ltle in
+  let ltle =
+    UMap.merge (fun _ a strict ->
+      match a, strict with
+      | Some _, Some true ->
+        (* There is a lt edge inside the new component. This is a
+            "bad cycle". *)
+        raise CycleDetected
+      | Some _, Some false -> None
+      | _, _ -> strict
+    ) to_merge_lvl ltle
+  in
+  let gtge =
+    UMap.fold (fun _ n acc -> LSet.union acc n.gtge)
+      to_merge_lvl LSet.empty
+  in
+  let gtge, _ = clean_gtge g gtge in
+  let gtge = LSet.diff gtge (UMap.domain to_merge_lvl) in
+  (ltle, gtge)
+
+
+let reorder g u v =
+  (* STEP 2: backward search in the k-level of u. *)
+  let delta = get_delta g in
+
+  (* [v_klvl] is the chosen future level for u, v and all
+      traversed nodes. *)
+  let b_traversed, v_klvl, g =
+    try
+      let to_revert, b_traversed, _, g = backward_traverse [] [] delta g u in
+      revert_graph to_revert g;
+      let v_klvl = (repr g u).klvl in
+      b_traversed, v_klvl, g
+    with AbortBackward g ->
+      (* Backward search was too long, use the next k-level. *)
+      let v_klvl = (repr g u).klvl + 1 in
+      [], v_klvl, g
+  in
+  let f_traversed, g =
+    (* STEP 3: forward search. Contrary to what is described in
+        the paper, we do not test whether v_klvl = u.klvl nor we assign
+        v_klvl to v.klvl. Indeed, the first call to forward_traverse
+        will do all that. *)
+    forward_traverse [] g v_klvl (repr g v) v
+  in
+
+  (* STEP 4: merge nodes if needed. *)
+  let to_merge, b_reindex, f_reindex =
+    if (repr g u).klvl = v_klvl then
+      begin
+        let merge, to_revert = find_to_merge [] g u v in
+        let r =
+          if merge then
+            List.filter (fun u -> u.status = ToMerge) to_revert,
+            List.filter (fun u -> (repr g u).status <> ToMerge) b_traversed,
+            List.filter (fun u -> (repr g u).status <> ToMerge) f_traversed
+          else [], b_traversed, f_traversed
+        in
+        List.iter (fun u -> u.status <- NoMark) to_revert;
+        r
+      end
+    else [], b_traversed, f_traversed
+  in
+  let to_reindex, g =
+    match to_merge with
+    | [] -> List.rev_append f_reindex b_reindex, g
+    | n0::q0 ->
+      (* Computing new root. *)
+      let root, rank_rest =
+        List.fold_left (fun ((best, rank_rest) as acc) n ->
+          if n.rank >= best.rank then n, best.rank else acc)
+          (n0, min_int) q0
+      in
+      let ltle, gtge = get_new_edges g to_merge in
+      (* Inserting the new root. *)
+      let g = change_node g
+        { root with ltle; gtge;
+          rank = max root.rank (rank_rest + 1); }
+      in
+
+      (* Inserting shortcuts for old nodes. *)
+      let g = List.fold_left (fun g n ->
+        if Level.equal n.univ root.univ then g else enter_equiv g n.univ root.univ)
+        g to_merge
+      in
+
+      (* Updating g.n_edges *)
+      let oldsz =
+        List.fold_left (fun sz u -> sz+UMap.cardinal u.ltle)
+          0 to_merge
+      in
+      let sz = UMap.cardinal ltle in
+      let g = { g with n_edges = g.n_edges + sz - oldsz } in
+
+      (* Not clear in the paper: we have to put the newly
+          created component just between B and F. *)
+      List.rev_append f_reindex (root.univ::b_reindex), g
+
+  in
+
+  (* STEP 5: reindex traversed nodes. *)
+  List.fold_left use_index g to_reindex
+
+(* Assumes [u] and [v] are already in the graph. *)
+(* Does NOT assume that ucan != vcan. *)
+let insert_edge strict ucan vcan g =
+  try
+    let u = ucan.univ and v = vcan.univ in
+    (* STEP 1: do we need to reorder nodes ? *)
+    let g = if topo_compare ucan vcan <= 0 then g else reorder g u v in
+
+    (* STEP 6: insert the new edge in the graph. *)
+    let u = repr g u in
+    let v = repr g v in
+    if u == v then
+      if strict then raise CycleDetected else g
+    else
+      let g =
+        try let oldstrict = UMap.find v.univ u.ltle in
+            if strict && not oldstrict then
+              change_node g { u with ltle = UMap.add v.univ true u.ltle }
+            else g
+        with Not_found ->
+          { (change_node g { u with ltle = UMap.add v.univ strict u.ltle })
+            with n_edges = g.n_edges + 1 }
+      in
+      if u.klvl <> v.klvl || LSet.mem u.univ v.gtge then g
+      else
+        let v = { v with gtge = LSet.add u.univ v.gtge } in
+        change_node g v
+  with
+  | CycleDetected as e -> raise e
+  | e ->
+    (** Unlikely event: fatal error or signal *)
+    let () = cleanup_universes g in
+    raise e
+
+let add_universe vlev strict g =
+  try
+    let _arcv = UMap.find vlev g.entries in
+      raise AlreadyDeclared
+  with Not_found ->
+    assert (g.index > min_int);
+    let v = {
+      univ = vlev;
+      ltle = LMap.empty;
+      gtge = LSet.empty;
+      rank = 0;
+      klvl = 0;
+      ilvl = g.index;
+      status = NoMark;
+    }
+    in
+    let entries = UMap.add vlev (Canonical v) g.entries in
+    let g = { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges } in
+    insert_edge strict (get_set_arc g) v g
+
+exception Found_explanation of explanation
+
+let get_explanation strict u v g =
+  let v = repr g v in
+  let visited_strict = ref UMap.empty in
+  let rec traverse strict u =
+    if u == v then
+      if strict then None else Some []
+    else if topo_compare u v = 1 then None
+    else
+      let visited =
+        try not (UMap.find u.univ !visited_strict) || strict
+        with Not_found -> false
+      in
+      if visited then None
+      else begin
+        visited_strict := UMap.add u.univ strict !visited_strict;
+        try
+          UMap.iter (fun u' strictu' ->
+            match traverse (strict && not strictu') (repr g u') with
+            | None -> ()
+            | Some exp ->
+              let typ = if strictu' then Lt else Le in
+              raise (Found_explanation ((typ, make u') :: exp)))
+            u.ltle;
+          None
+        with Found_explanation exp -> Some exp
+      end
+  in
+  let u = repr g u in
+  if u == v then [(Eq, make v.univ)]
+  else match traverse strict u with Some exp -> exp | None -> assert false
+
+let get_explanation strict u v g =
+  if !Flags.univ_print then Some (get_explanation strict u v g)
+  else None
+
+(* To compare two nodes, we simply do a forward search.
+   We implement two improvements:
+   - we ignore nodes that are higher than the destination;
+   - we do a BFS rather than a DFS because we expect to have a short
+       path (typically, the shortest path has length 1)
+*)
+exception Found of canonical_node list
+let search_path strict u v g =
+  let rec loop to_revert todo next_todo =
+    match todo, next_todo with
+    | [], [] -> to_revert (* No path found *)
+    | [], _ -> loop to_revert next_todo []
+    | (u, strict)::todo, _ ->
+      if u.status = Visited || (u.status = WeakVisited && strict)
+      then loop to_revert todo next_todo
+      else
+        let to_revert =
+          if u.status = NoMark then u::to_revert else to_revert
+        in
+        u.status <- if strict then WeakVisited else Visited;
+        if try UMap.find v.univ u.ltle || not strict
+           with Not_found -> false
+        then raise (Found to_revert)
+        else
+          begin
+            let next_todo =
+              UMap.fold (fun u strictu next_todo ->
+                let strict = not strictu && strict in
+                let u = repr g u in
+                if u == v && not strict then raise (Found to_revert)
+                else if topo_compare u v = 1 then next_todo
+                else (u, strict)::next_todo)
+               u.ltle next_todo
+            in
+            loop to_revert todo next_todo
+          end
+  in
+  if u == v then not strict
+  else
+    try
+      let res, to_revert =
+        try false, loop [] [u, strict] []
+        with Found to_revert -> true, to_revert
+      in
+      List.iter (fun u -> u.status <- NoMark) to_revert;
+      res
+    with e ->
+      (** Unlikely event: fatal error or signal *)
+      let () = cleanup_universes g in
+      raise e
+
+(** Uncomment to debug the cycle detection algorithm. *)
+(*let insert_edge strict ucan vcan g =
+  check_universes_invariants g;
+  let g = insert_edge strict ucan vcan g in
+  check_universes_invariants g;
+  let ucan = repr g ucan.univ in
+  let vcan = repr g vcan.univ in
+  assert (search_path strict ucan vcan g);
+  g*)
+
+(** First, checks on universe levels *)
+
+let check_equal g u v =
+  let arcu = repr g u and arcv = repr g v in
+    arcu == arcv
+
+let check_eq_level g u v = u == v || check_equal g u v
+
+let check_smaller g strict u v =
+  let arcu = repr g u and arcv = repr g v in
+  if strict then
+    search_path true arcu arcv g
+  else
+    is_prop_arc arcu 
+    || (is_set_arc arcu && not (is_prop_arc arcv))
+    || search_path false arcu arcv g
+
+(** Then, checks on universes *)
+
+type 'a check_function = universes -> 'a -> 'a -> bool
+
+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 =
+  Universe.exists (fun ul' -> 
+    check_smaller_expr g ul ul') l
+
+let real_check_leq g u v =
+  Universe.for_all (fun ul -> exists_bigger g ul v) u
+    
+let check_leq g u v =
+  Universe.equal u v ||
+    is_type0m_univ u ||
+    real_check_leq g u v
+
+let check_eq_univs g l1 l2 =
+  real_check_leq g l1 l2 && real_check_leq g l2 l1
+
+let check_eq g u v =
+  Universe.equal u v || check_eq_univs g u v
+
+(* enforce_univ_eq g u v will force u=v if possible, will fail otherwise *)
+
+let rec enforce_univ_eq u v g =
+  let ucan = repr g u in
+  let vcan = repr g v in
+  if topo_compare ucan vcan = 1 then enforce_univ_eq v u g
+  else
+    let g = insert_edge false ucan vcan g in  (* Cannot fail *)
+    try insert_edge false vcan ucan g
+    with CycleDetected ->
+      error_inconsistency Eq v u (get_explanation true u v g)
+
+(* enforce_univ_leq g u v will force u<=v if possible, will fail otherwise *)
+let enforce_univ_leq u v g =
+  let ucan = repr g u in
+  let vcan = repr g v in
+  try insert_edge false ucan vcan g
+  with CycleDetected ->
+    error_inconsistency Le u v (get_explanation true v u g)
+
+(* enforce_univ_lt u v will force u<v if possible, will fail otherwise *)
+let enforce_univ_lt u v g =
+  let ucan = repr g u in
+  let vcan = repr g v in
+  try insert_edge true ucan vcan g
+  with CycleDetected ->
+    error_inconsistency Lt u v (get_explanation false v u g)
+
+let empty_universes =
+  let set_arc = Canonical {
+    univ = Level.set;
+    ltle = LMap.empty;
+    gtge = LSet.empty;
+    rank = big_rank;
+    klvl = 0;
+    ilvl = (-1);
+    status = NoMark;
+  } in
+  let prop_arc = Canonical {
+    univ = Level.prop;
+    ltle = LMap.empty;
+    gtge = LSet.empty;
+    rank = big_rank;
+    klvl = 0;
+    ilvl = 0;
+    status = NoMark;
+  } in
+  let entries = UMap.add Level.set set_arc (UMap.singleton Level.prop prop_arc) in
+  let empty = { entries; index = (-2); n_nodes = 2; n_edges = 0 } in
+  enforce_univ_lt Level.prop Level.set empty
+
+(* Prop = Set is forbidden here. *)
+let initial_universes = empty_universes
+
+let is_initial_universes g = UMap.equal (==) g.entries initial_universes.entries
+
+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 merge_constraints c g =
+  Constraint.fold enforce_constraint c g
+
+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
+
+(* Normalization *)
+
+(** [normalize_universes g] returns a graph where all edges point
+    directly to the canonical representent of their target. The output
+    graph should be equivalent to the input graph from a logical point
+    of view, but optimized. We maintain the invariant that the key of
+    a [Canonical] element is its own name, by keeping [Equiv] edges. *)
+let normalize_universes g =
+  let g =
+    { g with
+      entries = UMap.map (fun entry ->
+        match entry with
+        | Equiv u -> Equiv ((repr g u).univ)
+        | Canonical ucan -> Canonical { ucan with rank = 1 })
+        g.entries }
+  in
+  UMap.fold (fun _ u g ->
+    match u with
+    | Equiv u -> g
+    | Canonical u ->
+      let _, u, g = get_ltle g u in
+      let _, _, g = get_gtge g u in
+      g)
+    g.entries g
+
+let constraints_of_universes g =
+  let constraints_of u v acc =
+    match v with
+    | Canonical {univ=u; ltle} ->
+      UMap.fold (fun v strict acc->
+        let typ = if strict then Lt else Le in
+        Constraint.add (u,typ,v) acc) ltle acc
+    | Equiv v -> Constraint.add (u,Eq,v) acc
+  in
+  UMap.fold constraints_of g.entries Constraint.empty
+
+let constraints_of_universes g =
+  constraints_of_universes (normalize_universes g)
+
+(** [sort_universes g] builds a totally ordered universe graph.  The
+    output graph should imply the input graph (and the implication
+    will be strict most of the time), but is not necessarily minimal.
+    Moreover, it adds levels [Type.n] to identify universes at level
+    n. An artificial constraint Set < Type.2 is added to ensure that
+    Type.n and small universes are not merged. 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 g =
+  let cans =
+    UMap.fold (fun _ u l ->
+      match u with
+      | Equiv _ -> l
+      | Canonical can -> can :: l
+    ) g.entries []
+  in
+  let cans = List.sort topo_compare cans in
+  let lowest_levels =
+    UMap.mapi (fun u _ -> if Level.is_small u then 0 else 2)
+      (UMap.filter
+         (fun _ u -> match u with Equiv _ -> false | Canonical _ -> true)
+         g.entries)
+  in
+  let lowest_levels =
+    List.fold_left (fun lowest_levels can ->
+      let lvl = UMap.find can.univ lowest_levels in
+      UMap.fold (fun u' strict lowest_levels ->
+        let cost = if strict then 1 else 0 in
+        let u' = (repr g u').univ in
+        UMap.modify u' (fun _ lvl0 -> max lvl0 (lvl+cost)) lowest_levels)
+       can.ltle lowest_levels)
+     lowest_levels cans
+  in
+  let max_lvl = UMap.fold (fun _ a b -> max a b) lowest_levels 0 in
+  let mp = Names.DirPath.make [Names.Id.of_string "Type"] in
+  let types = Array.init (max_lvl + 1) (function
+    | 0 -> Level.prop
+    | 1 -> Level.set
+    | n -> Level.make mp (n-2))
+  in
+  let g = Array.fold_left (fun g u ->
+    let g, u = safe_repr g u in
+    change_node g { u with rank = big_rank }) g types
+  in
+  let g = if max_lvl >= 2 then enforce_univ_lt Level.set types.(2) g else g in
+  let g =
+    UMap.fold (fun u lvl g -> enforce_univ_eq u (types.(lvl)) g)
+      lowest_levels g
+  in
+  normalize_universes g
+
+(** Instances *)
+
+let check_eq_instances g t1 t2 =
+  let t1 = Instance.to_array t1 in
+  let t2 = Instance.to_array t2 in
+  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)
+
+(** Pretty-printing *)
+
+let pr_arc prl = function
+  | _, Canonical {univ=u; ltle} ->
+    if UMap.is_empty ltle then mt ()
+    else
+      prl u ++ str " " ++
+      v 0
+        (pr_sequence (fun (v, strict) ->
+          (if strict then str "< " else str "<= ") ++ prl v)
+           (UMap.bindings ltle)) ++
+      fnl ()
+  | u, Equiv v ->
+      prl u  ++ str " = " ++ prl v ++ fnl ()
+
+let pr_universes prl g =
+  let graph = UMap.fold (fun u a l -> (u,a)::l) g.entries [] in
+  prlist (pr_arc prl) graph
+
+(* Dumping constraints to a file *)
+
+let dump_universes output g =
+  let dump_arc u = function
+    | Canonical {univ=u; ltle} ->
+        let u_str = Level.to_string u in
+        UMap.iter (fun v strict ->
+          let typ = if strict then Lt else Le in
+          output typ u_str (Level.to_string v)) ltle;
+    | Equiv v ->
+      output Eq (Level.to_string u) (Level.to_string v)
+  in
+  UMap.iter dump_arc g.entries
+
+(** Profiling *)
+
+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/uGraph.mli b/kernel/uGraph.mli
new file mode 100644
index 00000000..e95cf4d1
--- /dev/null
+++ b/kernel/uGraph.mli
@@ -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 Univ
+
+(** {6 Graphs of universes. } *)
+
+type t
+
+type universes = t
+
+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 >= or > Set.
+   @raises AlreadyDeclared if the level is already declared in the graph. *)
+
+exception AlreadyDeclared
+
+val add_universe : universe_level -> bool -> universes -> universes
+
+(** {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. *)
+
+val enforce_constraint : univ_constraint -> universes -> universes
+val merge_constraints : constraints -> universes -> universes
+
+val constraints_of_universes : universes -> constraints
+
+val check_constraint  : universes -> univ_constraint -> bool
+val check_constraints : constraints -> universes -> bool
+
+val check_eq_instances : Instance.t check_function
+(** Check equality of instances w.r.t. a universe graph *)
+
+(** {6 Pretty-printing of universes. } *)
+
+val pr_universes : (Level.t -> Pp.std_ppcmds) -> universes -> Pp.std_ppcmds
+
+(** {6 Dumping to a file } *)
+
+val dump_universes :
+  (constraint_type -> string -> string -> unit) ->
+  universes -> unit
diff --git a/kernel/univ.ml b/kernel/univ.ml
index 21ffafed..09f884ec 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.ml
@@ -12,11 +12,11 @@
 (* 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, Matthieu Sozeau, 
-   Pierre-Marie Pédrot *)
+(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu
+   Sozeau, Pierre-Marie Pédrot *)
 
 open Pp
-open Errors
+open CErrors
 open Util
 
 (* Universes are stratified by a partial ordering $\le$.
@@ -35,7 +35,7 @@ module type Hashconsed =
 sig
   type t
   val hash : t -> int
-  val equal : t -> t -> bool
+  val eq : t -> t -> bool
   val hcons : t -> t
 end
 
@@ -53,7 +53,7 @@ struct
     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
+    let eq l1 l2 = match l1, l2 with
     | Nil, Nil -> true
     | Cons (x1, _, l1), Cons (x2, _, l2) -> x1 == x2 && l1 == l2
     | _ -> false
@@ -135,12 +135,12 @@ module HList = struct
   let rec remove x = function
   | Nil -> nil
   | Cons (y, _, l) ->
-    if H.equal x y then l
+    if H.eq 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
+  | Cons (y, _, l) -> H.eq x y || mem x l
 
   let rec compare cmp l1 l2 = match l1, l2 with
   | Nil, Nil -> 0
@@ -251,7 +251,7 @@ module Level = struct
     type _t = t
     type t = _t
     type u = unit
-    let equal x y = x.hash == y.hash && RawLevel.hequal x.data y.data
+    let eq x y = x.hash == y.hash && RawLevel.hequal x.data y.data
     let hash x = x.hash
     let hashcons () x =
       let data' = RawLevel.hcons x.data in
@@ -400,7 +400,7 @@ struct
       let hashcons hdir (b,n as x) = 
 	let b' = hdir b in 
 	  if b' == b then x else (b',n)
-      let equal l1 l2 =
+      let eq l1 l2 =
         l1 == l2 || 
         match l1,l2 with
 	| (b,n), (b',n') -> b == b' && n == n'
@@ -419,7 +419,7 @@ struct
       let hcons =
 	Hashcons.simple_hcons H.generate H.hcons Level.hcons
       let hash = ExprHash.hash
-      let equal x y = x == y ||
+      let eq x y = x == y ||
 	(let (u,n) = x and (v,n') = y in
 	   Int.equal n n' && Level.equal u v)
 
@@ -468,15 +468,32 @@ struct
       else if Level.is_prop u then
 	hcons (Level.set,n+k)
       else hcons (u,n+k)
-	
+
+    type super_result =
+	SuperSame of bool
+        (* The level expressions are in cumulativity relation. boolean
+           indicates if left is smaller than right?  *)
+      | SuperDiff of int
+        (* The level expressions are unrelated, the comparison result
+           is canonical *)
+
+    (** [super u v] compares two level expressions,
+       returning [SuperSame] if they refer to the same level at potentially different
+       increments or [SuperDiff] if they are different. The booleans indicate if the
+       left expression is "smaller" than the right one in both cases. *)
     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
+	if Int.equal cmp 0 then SuperSame (n < n')
+	else
+	  match x, y with
+	  | (l,0), (l',0) ->
+	     let open RawLevel in
+	     (match Level.data l, Level.data l' with
+	      | Prop, Prop -> SuperSame false
+	      | Prop, _ -> SuperSame true
+	      | _, Prop -> SuperSame false
+	      | _, _ -> SuperDiff cmp)
+	  | _, _ -> SuperDiff cmp
 
     let to_string (v, n) =
       if Int.equal n 0 then Level.to_string v
@@ -598,24 +615,26 @@ struct
     | 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 open Expr in
+       (match super h1 h2 with
+	| SuperSame true (* h1 < h2 *) -> merge_univs t1 l2
+	| SuperSame false -> merge_univs l1 t2
+	| SuperDiff 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'))
+	let open Expr in
+        (match super a b with
+	 | SuperSame false -> aux a l'
+	 | SuperSame true -> l
+	 | SuperDiff 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
@@ -653,170 +672,6 @@ open Universe
 
 let universe_level = Universe.level
 
-type status = Unset | SetLe | SetLt
-
-(* Comparison on this type is pointer equality *)
-type canonical_arc =
-    { univ: Level.t;
-      lt: Level.t list;
-      le: Level.t list;
-      rank : int;
-      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; 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 *)
-
-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
-
-(* Every Level.t has a unique canonical arc representative *)
-
-(** The graph always contains nodes for Prop and Set. *)
-
-let terminal_lt u v =
-  {(terminal u) with lt=[v]}
-    
-let empty_universes =
-  let g = enter_arc (terminal Level.set) UMap.empty in
-  let g = enter_arc (terminal_lt Level.prop Level.set) g in
-    g
-
-(* repr : universes -> Level.t -> canonical_arc *)
-(* canonical representative : we follow the Equiv links *)
-
-let rec repr g 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 g v
-    | Canonical arc -> arc
-
-let get_prop_arc g = repr g Level.prop
-let get_set_arc g = repr g Level.set
-let is_set_arc u = Level.is_set u.univ
-let is_prop_arc u = Level.is_prop u.univ
-
-exception AlreadyDeclared
-	    
-let add_universe vlev strict g =
-  try
-    let _arcv = UMap.find vlev g in
-      raise AlreadyDeclared
-  with Not_found -> 
-    let v = terminal vlev in
-    let arc =
-      let arc = get_set_arc g in
-	if strict then
-	  { arc with lt=vlev::arc.lt}
-	else 
-	  { arc with le=vlev::arc.le}
-    in
-    let g = enter_arc arc g in
-      enter_arc v g
-
-(* 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
 
@@ -831,343 +686,6 @@ let constraint_type_ord c1 c2 = match c1, c2 with
 | Eq, Eq -> 0
 | Eq, _ -> 1
 
-(** [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.
-
-  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.
-
-  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 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
-  let start = (* if is_prop_arc arcu then [Le, make arcv.univ] else *) [] in
-  try
-    let (to_revert, c) = cmp start [] [] [(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 arc_is_lt arc then
-      cmp c to_revert lt_todo le_todo
-    else
-      let () = arc.status <- SetLt in
-      process_lt c (arc :: to_revert) lt_todo le_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 to_revert [] le_todo else (to_revert, FastLE)
-    else
-      if arc_is_le arc then
-        cmp c to_revert [] le_todo
-      else
-        let () = arc.status <- SetLe in
-        process_le c (arc :: to_revert) [] le_todo arc.lt arc.le
-
-  and process_lt c to_revert lt_todo le_todo lt le = match le with
-  | [] ->
-    begin match lt with
-    | [] -> cmp c 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 process_lt c to_revert (arc :: lt_todo) le_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 process_lt c to_revert (arc :: lt_todo) le_todo lt le
-
-  and process_le c to_revert lt_todo le_todo lt le = 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 le in
-    cmp c 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 process_le c to_revert (arc :: lt_todo) le_todo lt le
-
-  in
-  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 get_explanation_strict g arcu arcv = get_explanation true g arcu arcv
-
-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 arcu = repr g u and arcv = repr g v in
-    arcu == arcv
-
-let check_eq_level g u v = u == v || check_equal g u v
-
-let check_smaller g strict u v =
-  let arcu = repr g u and arcv = repr g v in
-  if strict then
-    is_lt g arcu arcv
-  else
-    is_prop_arc arcu 
-    || (is_set_arc arcu && not (is_prop_arc arcv))
-    || 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 : 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'
-
-(* 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
-    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 && not (Level.is_small best_arc.univ))
-      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 Level.is_small arc2.univ || 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. *)
 
@@ -1178,70 +696,10 @@ exception UniverseInconsistency of univ_inconsistency
 let error_inconsistency o u v (p:explanation option) =
   raise (UniverseInconsistency (o,make u,make v,p))
 
-(* enforce_univ_eq : Level.t -> Level.t -> unit *)
-(* enforce_univ_eq u v will force u=v if possible, will fail otherwise *)
-
-let enforce_univ_eq u v g =
-  let arcu = repr g u and arcv = 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 arcu = repr g u and arcv = repr g v in
-  if is_leq g arcu arcv then g
-  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 arcu = repr g u and arcv = 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 (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
-
-(* Prop = Set is forbidden here. *)
-let initial_universes = empty_universes
-
-let is_initial_universes g = UMap.equal (==) g initial_universes
-      
 (* 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 -> " < "
@@ -1276,8 +734,6 @@ end
 let empty_constraint = Constraint.empty
 let union_constraint = Constraint.union
 let eq_constraint = Constraint.equal
-let merge_constraints c g =
-  Constraint.fold enforce_constraint c g
 
 type constraints = Constraint.t
 
@@ -1287,7 +743,7 @@ module Hconstraint =
       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') =
+      let eq (l1,k,l2) (l1',k',l2') =
 	l1 == l1' && k == k' && l2 == l2'
       let hash = Hashtbl.hash
     end)
@@ -1299,7 +755,7 @@ module Hconstraints =
       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' =
+      let eq s s' =
 	List.for_all2eq (==)
 	  (Constraint.elements s)
 	  (Constraint.elements s')
@@ -1378,218 +834,12 @@ let 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 (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
-    graph should be equivalent to the input graph from a logical point
-    of view, but optimized. We maintain the invariant that the key of
-    a [Canonical] element is its own name, by keeping [Equiv] edges
-    (see the assertion)... I (Stéphane Glondu) am not sure if this
-    plays a role in the rest of the module. *)
-let normalize_universes g =
-  let rec visit u arc cache = match lookup_level u cache with
-    | Some x -> x, cache
-    | None -> match Lazy.force arc with
-    | None ->
-      u, UMap.add u u cache
-    | Some (Canonical {univ=v; lt=_; le=_}) ->
-      v, UMap.add u v cache
-    | Some (Equiv v) ->
-      let v, cache = visit v (lazy (lookup_level v g)) cache in
-      v, UMap.add u v cache
-  in
-  let cache = UMap.fold
-    (fun u arc cache -> snd (visit u (Lazy.lazy_from_val (Some arc)) cache))
-    g UMap.empty
-  in
-  let repr x = UMap.find x cache in
-  let lrepr us = List.fold_left
-    (fun e x -> LSet.add (repr x) e) LSet.empty us
-  in
-  let canonicalize u = function
-    | Equiv _ -> Equiv (repr u)
-    | Canonical {univ=v; lt=lt; le=le; rank=rank} ->
-      assert (u == v);
-      (* avoid duplicates and self-loops *)
-      let lt = lrepr lt and le = lrepr le in
-      let le = LSet.filter
-        (fun x -> x != u && not (LSet.mem x lt)) le
-      in
-      LSet.iter (fun x -> assert (x != u)) lt;
-      Canonical {
-        univ = v;
-        lt = LSet.elements lt;
-        le = LSet.elements le;
-	rank = rank;
-	status = Unset;
-      }
-  in
-  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
-  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
-  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
-  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
-  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 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 (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 i < max then
-      let pred = types.(i + 1) in
-      let arc = {univ = u; lt = [pred]; le = []; rank = 0; status = Unset; } in
-      UMap.add u (Canonical arc) accu
-    else accu
-  in
-  Array.fold_left_i fold sorted types
-
 (* Miscellaneous functions to remove or test local univ assumed to
    occur in a universe *)
 
@@ -1645,7 +895,6 @@ module Instance : sig
     
     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
@@ -1671,7 +920,7 @@ struct
 	  a
 	end
 
-    let equal t1 t2 =
+    let eq t1 t2 =
       t1 == t2 ||
 	(Int.equal (Array.length t1) (Array.length t2) &&
 	   let rec aux i =
@@ -1731,13 +980,6 @@ struct
 	 (* 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
 
 let enforce_eq_instances x y = 
@@ -1993,27 +1235,6 @@ let abstract_universes poly ctx =
 
 (** Pretty-printing *)
 
-let pr_arc prl = function
-  | _, Canonical {univ=u; lt=[]; le=[]} ->
-      mt ()
-  | _, Canonical {univ=u; lt=lt; le=le} ->
-      let opt_sep = match lt, le with
-      | [], _ | _, [] -> mt ()
-      | _ -> spc ()
-      in
-      prl u ++ str " " ++
-      v 0
-        (pr_sequence (fun v -> str "< " ++ prl v) lt ++
-	 opt_sep ++
-         pr_sequence (fun v -> str "<= " ++ prl v) le) ++
-      fnl ()
-  | u, Equiv v ->
-      prl u  ++ str " = " ++ prl v ++ fnl ()
-
-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 prl = Constraint.pr prl
 
 let pr_universe_context = UContext.pr
@@ -2026,19 +1247,6 @@ let pr_universe_subst =
 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 = Level.to_string u in
-	List.iter (fun v -> output Lt u_str (Level.to_string v)) lt;
-	List.iter (fun v -> output Le u_str (Level.to_string v)) le
-    | Equiv v ->
-      output Eq (Level.to_string u) (Level.to_string v)
-  in
-  UMap.iter dump_arc g
-
 module Huniverse_set = 
   Hashcons.Make(
     struct
@@ -2046,7 +1254,7 @@ module Huniverse_set =
       type u = universe_level -> universe_level
       let hashcons huc s =
 	LSet.fold (fun x -> LSet.add (huc x)) s LSet.empty
-      let equal s s' =
+      let eq s s' =
 	LSet.equal s s'
       let hash = Hashtbl.hash
     end)
@@ -2086,26 +1294,3 @@ let subst_instance_constraints =
     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 9788f129..1ccdebd5 100644
--- a/kernel/univ.mli
+++ b/kernel/univ.mli
@@ -40,6 +40,9 @@ sig
   val pr : t -> Pp.std_ppcmds
   (** Pretty-printing *)
 
+  val to_string : t -> string
+  (** Debug printing *)
+
   val var : int -> t
 
   val var_index : t -> int option
@@ -115,6 +118,9 @@ sig
   
   val type1 : t 
   (** the universe of the type of Prop/Set *)
+
+  val exists : (Level.t * int -> bool) -> t -> bool
+  val for_all : (Level.t * int -> bool) -> t -> bool
 end
 
 type universe = Universe.t
@@ -148,31 +154,6 @@ val univ_level_mem : universe_level -> universe -> bool
 
 val univ_level_rem : universe_level -> universe -> 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 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 >= or > Set.
-   @raises AlreadyDeclared if the level is already declared in the graph. *)
-
-exception AlreadyDeclared
-
-val add_universe : universe_level -> bool -> universes -> universes
-
 (** {6 Constraints. } *)
 
 type constraint_type = Lt | Le | Eq
@@ -203,12 +184,6 @@ 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.
-  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
@@ -226,14 +201,6 @@ type univ_inconsistency = constraint_type * universe * universe * explanation op
 
 exception UniverseInconsistency of univ_inconsistency
 
-val enforce_constraint : univ_constraint -> universes -> universes
-val merge_constraints : constraints -> universes -> universes
-
-val constraints_of_universes : universes -> constraints
-
-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 *)
@@ -309,8 +276,6 @@ sig
   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
@@ -428,7 +393,6 @@ val instantiate_univ_constraints : universe_instance -> universe_context -> cons
 
 (** {6 Pretty-printing of universes. } *)
 
-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
@@ -439,12 +403,6 @@ val explain_universe_inconsistency : (Level.t -> 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 } *)
-
-val dump_universes :
-  (constraint_type -> string -> string -> unit) ->
-  universes -> unit
-
 (** {6 Hash-consing } *)
 
 val hcons_univ : universe -> universe
diff --git a/kernel/vars.ml b/kernel/vars.ml
index 6bdae992..2ca749d5 100644
--- a/kernel/vars.ml
+++ b/kernel/vars.ml
@@ -8,7 +8,7 @@
 
 open Names
 open Esubst
-open Context
+open Context.Rel.Declaration
 
 (*********************)
 (*     Occurring     *)
@@ -151,20 +151,33 @@ let make_subst = function
   done;
   subst
 
+(* The type of substitutions, with term substituting most recent
+    binder at the head *)
+
+type substl = Constr.t list
+
 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_decl laml k r = map_constr (fun c -> substnl laml k c) r
+let substl_decl laml r = map_constr (fun c -> substnl laml 0 c) r
+let subst1_decl lam r = map_constr (fun c -> subst1 lam c) r
+
+(* Build a substitution from an instance, inserting missing let-ins *)
+
+let subst_of_rel_context_instance sign l =
+  let rec aux subst sign l =
+    match sign, l with
+    | LocalAssum _ :: sign', a::args' -> aux (a::subst) sign' args'
+    | LocalDef (_,c,_)::sign', args' ->
+	aux (substl subst c :: subst) sign' args'
+    | [], [] -> subst
+    | _ -> CErrors.anomaly (Pp.str "Instance and signature do not match")
+  in aux [] (List.rev sign) l
 
-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
+let adjust_subst_to_rel_context sign l =
+  List.rev (subst_of_rel_context_instance sign l)
 
 (* (thin_val sigma) removes identity substitutions from sigma *)
 
@@ -197,15 +210,10 @@ let replace_vars var_alist x =
     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 *)
+(* (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 *)
+(* (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
@@ -294,7 +302,7 @@ let subst_univs_level_constr subst c =
       if !changed then c' else c
 
 let subst_univs_level_context s = 
-  map_rel_context (subst_univs_level_constr s)
+  Context.Rel.map (subst_univs_level_constr s)
       
 let subst_instance_constr subst c =
   if Univ.Instance.is_empty subst then c
@@ -335,7 +343,7 @@ let subst_instance_constr subst 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
+  else Context.Rel.map (fun x -> subst_instance_constr s x) ctx
 
 type id_key = constant tableKey
 let eq_id_key x y = Names.eq_table_key Constant.equal x y
diff --git a/kernel/vars.mli b/kernel/vars.mli
index 501a5b85..574d50ec 100644
--- a/kernel/vars.mli
+++ b/kernel/vars.mli
@@ -8,7 +8,6 @@
 
 open Names
 open Constr
-open Context
 
 (** {6 Occur checks } *)
 
@@ -42,32 +41,85 @@ 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]
+(** The type [substl] is the type of substitutions [u₁..un] of type
+    some context Δ and defined in some environment Γ. Typing of
+    substitutions is defined by:
+    - Γ ⊢ ∅ : ∅,
+    - Γ ⊢ u₁..u{_n-1} : Δ and Γ ⊢ u{_n} : An\[u₁..u{_n-1}\] implies
+      Γ ⊢ u₁..u{_n} : Δ,x{_n}:A{_n}
+    - Γ ⊢ u₁..u{_n-1} : Δ and Γ ⊢ un : A{_n}\[u₁..u{_n-1}\] implies
+      Γ ⊢ u₁..u{_n} : Δ,x{_n}:=c{_n}:A{_n} when Γ ⊢ u{_n} ≡ c{_n}\[u₁..u{_n-1}\]
+
+    Note that [u₁..un] is represented as a list with [un] at the head of
+    the list, i.e. as [[un;...;u₁]]. *)
+
+type substl = constr list
+
+(** Let [Γ] be a context interleaving declarations [x₁:T₁..xn:Tn]
+   and definitions [y₁:=c₁..yp:=cp] in some context [Γ₀]. Let
+   [u₁..un] be an {e instance} of [Γ], i.e. an instance in [Γ₀]
+   of the [xi]. Then, [subst_of_rel_context_instance Γ u₁..un]
+   returns the corresponding {e substitution} of [Γ], i.e. the
+   appropriate interleaving [σ] of the [u₁..un] with the [c₁..cp],
+   all of them in [Γ₀], so that a derivation [Γ₀, Γ, Γ₁|- t:T]
+   can be instantiated into a derivation [Γ₀, Γ₁ |- t[σ]:T[σ]] using
+   [substnl σ |Γ₁| t].
+   Note that the instance [u₁..un] is represented starting with [u₁],
+   as if usable in [applist] while the substitution is
+   represented the other way round, i.e. ending with either [u₁] or
+   [c₁], as if usable for [substl]. *)
+val subst_of_rel_context_instance : Context.Rel.t -> constr list -> substl
+
+(** For compatibility: returns the substitution reversed *)
+val adjust_subst_to_rel_context : Context.Rel.t -> constr list -> constr list
+
+(** [substnl [a₁;...;an] k c] substitutes in parallel [a₁],...,[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
+    accordingly indexes in [an],...,[a1] and [c]. In terms of typing, if
+    Γ ⊢ a{_n}..a₁ : Δ and Γ, Δ, Γ' ⊢ c : T with |Γ'|=k, then
+    Γ, Γ' ⊢ [substnl [a₁;...;an] k c] : [substnl [a₁;...;an] k T]. *)
+val substnl : substl -> int -> constr -> constr
+
+(** [substl σ c] is a short-hand for [substnl σ 0 c] *)
+val substl : substl -> constr -> constr
+
+(** [substl a c] is a short-hand for [substnl [a] 0 c] *)
 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
+(** [substnl_decl [a₁;...;an] k Ω] substitutes in parallel [a₁], ..., [an]
+    for respectively [Rel(k+1)], ..., [Rel(k+n)] in [Ω]; it relocates
+    accordingly indexes in [a₁],...,[an] and [c]. In terms of typing, if
+    Γ ⊢ a{_n}..a₁ : Δ and Γ, Δ, Γ', Ω ⊢ with |Γ'|=[k], then
+    Γ, Γ', [substnl_decl [a₁;...;an]] k Ω ⊢. *)
+val substnl_decl : substl -> int -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t
 
-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
+(** [substl_decl σ Ω] is a short-hand for [substnl_decl σ 0 Ω] *)
+val substl_decl : substl -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t
 
+(** [subst1_decl a Ω] is a short-hand for [substnl_decl [a] 0 Ω] *)
+val subst1_decl : constr -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t
+
+(** [replace_vars k [(id₁,c₁);...;(idn,cn)] t] substitutes [Var idj] by
+    [cj] in [t]. *)
 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 *)
+(** [substn_vars k [id₁;...;idn] t] substitutes [Var idj] by [Rel j+k-1] in [t].
+   If two names are identical, the one of least index is kept. In terms of
+   typing, if Γ,x{_n}:U{_n},...,x₁:U₁,Γ' ⊢ t:T, together with id{_j}:T{_j} and
+   Γ,x{_n}:U{_n},...,x₁:U₁,Γ' ⊢ T{_j}\[id{_j+1}..id{_n}:=x{_j+1}..x{_n}\] ≡ Uj,
+   then Γ\\{id₁,...,id{_n}\},x{_n}:U{_n},...,x₁:U₁,Γ' ⊢ [substn_vars
+   (|Γ'|+1) [id₁;...;idn] t] : [substn_vars (|Γ'|+1) [id₁;...;idn]
+   T]. *)
+val substn_vars : int -> Id.t list -> constr -> constr
+
+(** [subst_vars [id1;...;idn] t] is a short-hand for [substn_vars
+   [id1;...;idn] 1 t]: it substitutes [Var idj] by [Rel j] in [t]. If
+   two names are identical, the one of least index is kept. *)
 val subst_vars : Id.t list -> constr -> constr
 
-(** [substn_vars n [id1;...;idk] 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
+(** [subst_var id t] is a short-hand for [substn_vars [id] 1 t]: it
+    substitutes [Var id] by [Rel 1] in [t]. *)
+val subst_var : Id.t -> constr -> constr
 
 (** {3 Substitution of universes} *)
 
@@ -82,11 +134,11 @@ 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
+val subst_univs_level_context : Univ.universe_level_subst -> Context.Rel.t -> Context.Rel.t
 
 (** Instance substitution for polymorphism. *)
 val subst_instance_constr : universe_instance -> constr -> constr
-val subst_instance_context : universe_instance -> rel_context -> rel_context
+val subst_instance_context : universe_instance -> Context.Rel.t -> Context.Rel.t
 
 type id_key = constant tableKey
 val eq_id_key : id_key -> id_key -> bool
diff --git a/kernel/vconv.ml b/kernel/vconv.ml
index 4610dbcb..74d956be 100644
--- a/kernel/vconv.ml
+++ b/kernel/vconv.ml
@@ -1,13 +1,9 @@
 open Util
 open Names
-open Term
 open Environ
-open Conv_oracle
 open Reduction
-open Closure
 open Vm
 open Csymtable
-open Univ
 
 let val_of_constr env c =
   val_of_constr (pre_env env) c
@@ -81,6 +77,7 @@ and conv_whd env pb k whd1 whd2 cu =
   | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) ->
       conv_atom env pb k a1 stk1 a2 stk2 cu
   | Vfun _, _ | _, Vfun _ ->
+     (* on the fly eta expansion *)
       conv_val env CONV (k+1) (apply_whd k whd1) (apply_whd k whd2) cu
 
   | Vsort _, _ | Vprod _, _ | Vfix _, _ | Vcofix _, _  | Vconstr_const _, _
@@ -120,14 +117,14 @@ and conv_atom env pb k a1 stk1 a2 stk2 cu =
   | Atype _ , _ | _, Atype _ -> assert false
   | Aind _, _ | Aid _, _ -> raise NotConvertible
 
-and conv_stack env ?from:(from=0) 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 env k stk1 stk2 (conv_arguments env ~from:from 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 env k stk1 stk2
-	(conv_arguments env ~from:from k args1 args2 (conv_fix env k f1 f2 cu))
+	(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
@@ -189,10 +186,9 @@ let vm_conv_gen cv_pb env univs t1 t2 =
     let v2 = val_of_constr env t2 in
     fst (conv_val env cv_pb (nb_rel env) v1 v2 univs)
   with Not_found | Invalid_argument _ ->
-    (Pp.msg_warning
-      (Pp.str "Bytecode compilation failed, falling back to default conversion");
-     Reduction.generic_conv cv_pb ~l2r:false (fun _ -> None)
-			    full_transparent_state env univs t1 t2)
+    warn_bytecode_compiler_failed ();
+    Reduction.generic_conv cv_pb ~l2r:false (fun _ -> None)
+      full_transparent_state env univs t1 t2
 
 let vm_conv cv_pb env t1 t2 =
   let univs = Environ.universes env in
diff --git a/kernel/vconv.mli b/kernel/vconv.mli
index 7e5397c0..ff01735c 100644
--- a/kernel/vconv.mli
+++ b/kernel/vconv.mli
@@ -12,7 +12,7 @@ open Reduction
 
 (**********************************************************************
   s conversion functions *)
-val vm_conv : conv_pb -> types conversion_function
+val vm_conv : conv_pb -> types kernel_conversion_function
 
 (** A conversion function parametrized by a universe comparator. Used outside of
     the kernel. *)
diff --git a/kernel/vm.ml b/kernel/vm.ml
index 70298764..53483a22 100644
--- a/kernel/vm.ml
+++ b/kernel/vm.ml
@@ -170,7 +170,7 @@ type whd =
 external push_ra : tcode -> unit = "coq_push_ra"
 external push_val : values -> unit = "coq_push_val"
 external push_arguments : arguments -> unit = "coq_push_arguments"
-external push_vstack : vstack -> unit = "coq_push_vstack"
+external push_vstack : vstack -> int -> unit = "coq_push_vstack"
 
 
 (* interpreteur *)
@@ -206,7 +206,9 @@ let apply_varray vf varray =
   else
     begin
       push_ra stop;
-      push_vstack varray;
+      (* The fun code of [vf] will make sure we have enough stack, so we put 0
+         here. *)
+      push_vstack varray 0;
       interprete (fun_code vf) vf (Obj.magic vf) (n - 1)
     end
 
@@ -232,7 +234,7 @@ let uni_lvl_val (v : values) : Univ.universe_level =
         | Vatom_stk (a,stk) -> str "Vatom_stk"
         | _ -> assert false
       in
-      Errors.anomaly
+      CErrors.anomaly
         Pp.(   strbrk "Parsing virtual machine value expected universe level, got "
             ++ pr)
 
@@ -282,7 +284,7 @@ let rec whd_accu a stk =
       | _           -> assert false
       end
   | tg ->
-    Errors.anomaly
+    CErrors.anomaly
       Pp.(strbrk "Failed to parse VM value. Tag = " ++ int tg)
 
 external kind_of_closure : Obj.t -> int = "coq_kind_of_closure"
@@ -306,7 +308,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)), [])
-	   | _ -> Errors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work"))
+	   | _ -> CErrors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work"))
 	else
            Vconstr_block(Obj.obj o)
 
@@ -560,7 +562,9 @@ let check_switch sw1 sw2 = sw1.sw_annot.rtbl = sw2.sw_annot.rtbl
 let case_info sw = sw.sw_annot.ci
 
 let type_of_switch sw =
-  push_vstack sw.sw_stk;
+  (* The fun code of types will make sure we have enough stack, so we put 0
+  here. *)
+  push_vstack sw.sw_stk 0;
   interprete sw.sw_type_code crazy_val sw.sw_env 0
 
 let branch_arg k (tag,arity) =
@@ -580,9 +584,10 @@ let branch_arg k (tag,arity) =
 let apply_switch sw arg =
   let tc = sw.sw_annot.tailcall in
   if tc then
-    (push_ra stop;push_vstack sw.sw_stk)
+    (push_ra stop;push_vstack sw.sw_stk sw.sw_annot.max_stack_size)
   else
-    (push_vstack sw.sw_stk; push_ra (popstop_code (Array.length sw.sw_stk)));
+    (push_vstack sw.sw_stk sw.sw_annot.max_stack_size;
+     push_ra (popstop_code (Array.length sw.sw_stk)));
   interprete sw.sw_code arg sw.sw_env 0
 
 let branch_of_switch k sw =
diff --git a/lib/aux_file.ml b/lib/aux_file.ml
index f7bd81f8..0f0f09aa 100644
--- a/lib/aux_file.ml
+++ b/lib/aux_file.ml
@@ -17,6 +17,10 @@ let version = 1
 
 let oc = ref None
 
+let chop_extension f =
+  if check_suffix f ".v" then chop_extension f
+  else f
+
 let aux_file_name_for vfile =
   dirname vfile ^ "/." ^ chop_extension(basename vfile) ^ ".aux"
 
@@ -25,9 +29,9 @@ let mk_absolute vfile =
   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));
+let start_aux_file ~aux_file:output_file ~v_file =
+  let vfile = mk_absolute v_file in
+  oc := Some (open_out output_file);
   Printf.fprintf (Option.get !oc) "COQAUX%d %s %s\n"
     version (Digest.to_hex (Digest.file vfile)) vfile
 
@@ -87,8 +91,7 @@ let load_aux_file_for vfile =
   | 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);
+    Flags.if_verbose Feedback.msg_info 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/lib/aux_file.mli b/lib/aux_file.mli
index 127827ab..86e322b7 100644
--- a/lib/aux_file.mli
+++ b/lib/aux_file.mli
@@ -17,7 +17,8 @@ module H : Map.S with type key = int * int
 module M : Map.S with type key = string
 val contents : aux_file -> string M.t H.t
 
-val start_aux_file_for : string -> unit
+val aux_file_name_for : string -> string
+val start_aux_file : aux_file:string -> v_file:string -> unit
 val stop_aux_file : unit -> unit 
 val recording : unit -> bool
 
diff --git a/lib/ephemeron.ml b/lib/cEphemeron.ml
index a38ea11e..a38ea11e 100644
--- a/lib/ephemeron.ml
+++ b/lib/cEphemeron.ml
diff --git a/lib/ephemeron.mli b/lib/cEphemeron.mli
index 1200e4e2..1200e4e2 100644
--- a/lib/ephemeron.mli
+++ b/lib/cEphemeron.mli
diff --git a/lib/errors.ml b/lib/cErrors.ml
index c1d224df..5c56192f 100644
--- a/lib/errors.ml
+++ b/lib/cErrors.ml
@@ -16,6 +16,23 @@ let push = Backtrace.add_backtrace
 
 exception Anomaly of string option * std_ppcmds (* System errors *)
 
+(* XXX: To move to common tagging functions in Pp, blocked on tag
+ * system cleanup as we cannot define generic error tags now.
+ *
+ * Anyways, tagging should not happen here, but in the specific
+ * listener to the msg_* stuff.
+ *)
+let tag_err_str s = tag Ppstyle.(Tag.inj error_tag tag) (str s) ++ spc ()
+let err_str       = tag_err_str "Error:"
+let ann_str       = tag_err_str "Anomaly:"
+
+let _ =
+  let pr = function
+  | Anomaly (s, pp) -> Some ("\"Anomaly: " ^ string_of_ppcmds pp ^ "\"")
+  | _ -> None
+  in
+  Printexc.register_printer pr
+
 let make_anomaly ?label pp =
   Anomaly (label, pp)
 
@@ -86,7 +103,9 @@ let print_backtrace e = match Backtrace.get_backtrace e with
 
 let print_anomaly askreport e =
   if askreport then
-    hov 0 (str "Anomaly: " ++ raw_anomaly e ++ spc () ++ str "Please report.")
+    hov 0 (ann_str ++ raw_anomaly e ++ spc () ++
+           strbrk "Please report at " ++ str Coq_config.wwwbugtracker ++
+           str ".")
   else
     hov 0 (raw_anomaly e)
 
@@ -106,7 +125,7 @@ let iprint_no_report (e, info) =
 
 let _ = register_handler begin function
   | UserError(s, pps) ->
-    hov 0 (str "Error: " ++ where (Some s) ++ pps)
+    hov 0 (err_str ++ where (Some s) ++ pps)
   | _ -> raise Unhandled
 end
 
@@ -137,5 +156,5 @@ let handled e =
 let fatal_error info anomaly =
   let msg = info ++ fnl () in
   pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft msg;
-  flush_all ();
+  Format.pp_print_flush !Pp_control.err_ft ();
   exit (if anomaly then 129 else 1)
diff --git a/lib/errors.mli b/lib/cErrors.mli
index e5dad93f..e5dad93f 100644
--- a/lib/errors.mli
+++ b/lib/cErrors.mli
diff --git a/lib/cList.ml b/lib/cList.ml
index 0ac372d8..c8283e3c 100644
--- a/lib/cList.ml
+++ b/lib/cList.ml
@@ -47,7 +47,11 @@ sig
     ('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 partitioni :
+    (int -> 'a -> bool) -> 'a list -> 'a list * 'a list
   val smartfilter : ('a -> bool) -> 'a list -> 'a list
+  val extend : bool list -> 'a -> 'a list -> 'a list
+  val count : ('a -> bool) -> 'a list -> int
   val index : 'a eq -> 'a -> 'a list -> int
   val index0 : 'a eq -> 'a -> 'a list -> int
   val iteri :  (int -> 'a -> unit) -> 'a list -> unit
@@ -61,6 +65,7 @@ sig
   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 extract_first : ('a -> bool) -> 'a list -> 'a list * 'a
   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
@@ -375,6 +380,18 @@ let rec smartfilter f l = match l with
           else h :: tl'
         else tl'
 
+let rec extend l a l' = match l,l' with
+  | true::l, b::l' -> b :: extend l a l'
+  | false::l, l' -> a :: extend l a l'
+  | [], [] -> []
+  | _ -> invalid_arg "extend"
+
+let count f l =
+  let rec aux acc = function
+    | [] -> acc
+    | h :: t -> if f h then aux (acc + 1) t else aux acc t in
+  aux 0 l
+
 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)
@@ -445,6 +462,14 @@ let rec remove_first p = function
   | b::l -> b::remove_first p l
   | [] -> raise Not_found
 
+let extract_first p li =
+  let rec loop rev_left = function
+    | [] -> raise Not_found
+    | x::right ->
+       if p x then List.rev_append rev_left right, x
+       else loop (x :: rev_left) right
+  in loop [] li
+
 let insert p v l =
   let rec insrec = function
     | [] -> [v]
@@ -472,6 +497,15 @@ let filteri p =
   in
   filter_i_rec 0
 
+let partitioni p =
+  let rec aux i = function
+    | [] -> [], []
+    | x :: l ->
+        let (l1, l2) = aux (succ i) l in
+        if p i x then (x :: l1, l2)
+        else (l1, x :: l2)
+  in aux 0
+
 let rec sep_last = function
   | [] -> failwith "sep_last"
   | hd::[] -> (hd,[])
@@ -567,19 +601,35 @@ let filter2 f l1 l2 =
   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 rec map_filter_loop f p = function
+  | [] -> ()
+  | x :: l ->
+    match f x with
+    | None -> map_filter_loop f p l
+    | Some y ->
+      let c = { head = y; tail = [] } in
+      p.tail <- cast c;
+      map_filter_loop f c l
+
+let map_filter f l =
+  let c = { head = Obj.magic 0; tail = [] } in
+  map_filter_loop f c l;
+  c.tail
 
-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 map_filter_i_loop f i p = function
+  | [] -> ()
+  | x :: l ->
+    match f i x with
+    | None -> map_filter_i_loop f (succ i) p l
+    | Some y ->
+      let c = { head = y; tail = [] } in
+      p.tail <- cast c;
+      map_filter_i_loop f (succ i) c l
+
+let map_filter_i f l =
+  let c = { head = Obj.magic 0; tail = [] } in
+  map_filter_i_loop f 0 c l;
+  c.tail
 
 let rec filter_with filter l = match filter, l with
 | [], [] -> []
@@ -638,12 +688,13 @@ let rec split3 = function
       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)
+  let rec aux acc n l =
+    match n, l with
+    | 0, _ -> List.rev acc
+    | n, h::t -> aux (h::acc) (pred n) t
     | _ -> failwith "firstn"
   in
-  aux [] (n,l)
+  aux [] n l
 
 let rec last = function
   | [] -> failwith "List.last"
diff --git a/lib/cList.mli b/lib/cList.mli
index 19eeb250..bc8749b4 100644
--- a/lib/cList.mli
+++ b/lib/cList.mli
@@ -89,11 +89,17 @@ sig
   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 partitioni : (int -> 'a -> bool) -> 'a list -> '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 extend : bool list -> 'a -> 'a list -> 'a list
+(** [extend l a [a1..an]] assumes that the number of [true] in [l] is [n];
+    it extends [a1..an] by inserting [a] at the position of [false] in [l] *)
+  val count : ('a -> bool) -> 'a list -> int
+
   val index : 'a eq -> 'a -> 'a list -> int
   (** [index] returns the 1st index of an element in a list (counting from 1). *)
 
@@ -119,6 +125,10 @@ sig
   val remove_first : ('a -> bool) -> 'a list -> 'a list
   (** Remove the first element satisfying a predicate, or raise [Not_found] *)
 
+  val extract_first : ('a -> bool) -> 'a list -> 'a list * 'a
+  (** Remove and return 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 *)
diff --git a/lib/cMap.ml b/lib/cMap.ml
index 665e1a21..ba0873ff 100644
--- a/lib/cMap.ml
+++ b/lib/cMap.ml
@@ -12,12 +12,20 @@ sig
   val compare : t -> t -> int
 end
 
+module type MonadS =
+sig
+  type +'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+end
+
 module type S = Map.S
 
 module type ExtS =
 sig
   include CSig.MapS
   module Set : CSig.SetS with type elt = key
+  val get : key -> 'a t -> 'a
   val update : key -> 'a -> 'a t -> 'a t
   val modify : key -> (key -> 'a -> 'a) -> 'a t -> 'a t
   val domain : 'a t -> Set.t
@@ -26,10 +34,17 @@ sig
   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
+  val height : 'a t -> int
   module Unsafe :
   sig
     val map : (key -> 'a -> key * 'b) -> 'a t -> 'b t
   end
+  module Monad(M : MonadS) :
+  sig
+    val fold : (key -> 'a -> 'b -> 'b M.t) -> 'a t -> 'b -> 'b M.t
+    val fold_left : (key -> 'a -> 'b -> 'b M.t) -> 'a t -> 'b -> 'b M.t
+    val fold_right : (key -> 'a -> 'b -> 'b M.t) -> 'a t -> 'b -> 'b M.t
+  end
 end
 
 module MapExt (M : Map.OrderedType) :
@@ -43,10 +58,17 @@ sig
   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
+  val height : 'a map -> int
   module Unsafe :
   sig
     val map : (M.t -> 'a -> M.t * 'b) -> 'a map -> 'b map
   end
+  module Monad(MS : MonadS) :
+  sig
+    val fold : (M.t -> 'a -> 'b -> 'b MS.t) -> 'a map -> 'b -> 'b MS.t
+    val fold_left : (M.t -> 'a -> 'b -> 'b MS.t) -> 'a map -> 'b -> 'b MS.t
+    val fold_right : (M.t -> 'a -> 'b -> 'b MS.t) -> 'a map -> 'b -> 'b MS.t
+  end
 end =
 struct
   (** This unsafe module is a way to access to the actual implementations of
@@ -148,6 +170,10 @@ struct
     if l == l' && r == r' && v == v' then s
     else map_inj (MNode (l', k, v', r', h))
 
+  let height s = match map_prj s with
+  | MEmpty -> 0
+  | MNode (_, _, _, _, h) -> h
+
   module Unsafe =
   struct
 
@@ -159,10 +185,34 @@ struct
 
   end
 
+  module Monad(M : MonadS) =
+  struct
+
+    open M
+
+    let rec fold_left f s accu = match map_prj s with
+    | MEmpty -> return accu
+    | MNode (l, k, v, r, h) ->
+      fold_left f l accu >>= fun accu ->
+      f k v accu >>= fun accu ->
+      fold_left f r accu
+
+    let rec fold_right f s accu = match map_prj s with
+    | MEmpty -> return accu
+    | MNode (l, k, v, r, h) ->
+      fold_right f r accu >>= fun accu ->
+      f k v accu >>= fun accu ->
+      fold_right f l accu
+
+    let fold = fold_left
+
+  end
+
 end
 
 module Make(M : Map.OrderedType) =
 struct
   include Map.Make(M)
   include MapExt(M)
+  let get k m = try find k m with Not_found -> assert false
 end
diff --git a/lib/cMap.mli b/lib/cMap.mli
index 2f243da8..2838b374 100644
--- a/lib/cMap.mli
+++ b/lib/cMap.mli
@@ -14,6 +14,13 @@ sig
   val compare : t -> t -> int
 end
 
+module type MonadS =
+sig
+  type +'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+end
+
 module type S = Map.S
 
 module type ExtS =
@@ -24,6 +31,9 @@ sig
   module Set : CSig.SetS with type elt = key
   (** Sets used by the domain function *)
 
+  val get : key -> 'a t -> 'a
+  (** Same as {!find} but fails an assertion instead of raising [Not_found] *)
+
   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. *)
@@ -51,6 +61,9 @@ sig
   val smartmapi : (key -> 'a -> 'a) -> 'a t -> 'a t
   (** As [mapi] but tries to preserve sharing. *)
 
+  val height : 'a t -> int
+  (** An indication of the logarithmic size of a map *)
+
   module Unsafe :
   sig
     val map : (key -> 'a -> key * 'b) -> 'a t -> 'b t
@@ -59,6 +72,14 @@ sig
         i.e.: for all (k : key) (x : 'a), compare (fst (f k x)) k = 0. *)
   end
 
+  module Monad(M : MonadS) :
+  sig
+    val fold : (key -> 'a -> 'b -> 'b M.t) -> 'a t -> 'b -> 'b M.t
+    val fold_left : (key -> 'a -> 'b -> 'b M.t) -> 'a t -> 'b -> 'b M.t
+    val fold_right : (key -> 'a -> 'b -> 'b M.t) -> 'a t -> 'b -> 'b M.t
+  end
+  (** Fold operators parameterized by any monad. *)
+
 end
 
 module Make(M : Map.OrderedType) : ExtS with
diff --git a/lib/cSet.ml b/lib/cSet.ml
index 3eeff29f..037cdc35 100644
--- a/lib/cSet.ml
+++ b/lib/cSet.ml
@@ -57,7 +57,7 @@ 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 eq 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
diff --git a/lib/cSig.mli b/lib/cSig.mli
index e095c82c..151cfbdc 100644
--- a/lib/cSig.mli
+++ b/lib/cSig.mli
@@ -14,6 +14,8 @@ type ('a, 'b) union = Inl of 'a | Inr of 'b
 type 'a until = Stop of 'a | Cont of 'a
 (** Used for browsable-until structures. *)
 
+type (_, _) eq = Refl : ('a, 'a) eq
+
 module type SetS =
 sig
     type elt
@@ -46,6 +48,8 @@ end
 (** Redeclaration of OCaml set signature, to preserve compatibility. See OCaml
     documentation for more information. *)
 
+module type EmptyS = sig end
+
 module type MapS =
 sig
     type key
diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml
new file mode 100644
index 00000000..cc2463e2
--- /dev/null
+++ b/lib/cWarnings.ml
@@ -0,0 +1,188 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Pp
+
+type status =
+  Disabled | Enabled | AsError
+
+type t = {
+  default : status;
+  category : string;
+  status : status;
+}
+
+let warnings : (string, t) Hashtbl.t = Hashtbl.create 97
+let categories : (string, string list) Hashtbl.t = Hashtbl.create 97
+
+let current_loc = ref Loc.ghost
+let flags = ref ""
+
+let set_current_loc = (:=) current_loc
+
+let get_flags () = !flags
+
+let add_warning_in_category ~name ~category =
+  let ws =
+    try
+      Hashtbl.find categories category
+    with Not_found -> []
+  in
+  Hashtbl.replace categories category (name::ws)
+
+let refine_loc = function
+  | None when not (Loc.is_ghost !current_loc) -> Some !current_loc
+  | loc -> loc
+
+let create ~name ~category ?(default=Enabled) pp =
+  Hashtbl.add warnings name { default; category; status = default };
+  add_warning_in_category ~name ~category;
+  if default <> Disabled then
+    add_warning_in_category ~name ~category:"default";
+  fun ?loc x -> let w = Hashtbl.find warnings name in
+           match w.status with
+           | Disabled -> ()
+           | AsError ->
+              begin match refine_loc loc with
+              | Some loc -> CErrors.user_err_loc (loc,"_",pp x)
+              | None -> CErrors.errorlabstrm "_" (pp x)
+              end
+           | Enabled ->
+              let msg =
+                pp x ++ spc () ++ str "[" ++ str name ++ str "," ++
+                  str category ++ str "]"
+              in
+              let loc = refine_loc loc in
+              Feedback.msg_warning ?loc msg
+
+let warn_unknown_warning =
+  create ~name:"unknown-warning" ~category:"toplevel"
+         (fun name -> strbrk "Unknown warning name: " ++ str name)
+
+let set_warning_status ~name status =
+  try
+    let w = Hashtbl.find warnings name in 
+    Hashtbl.replace warnings name { w with status = status }
+  with Not_found -> ()
+
+let reset_default_warnings () =
+  Hashtbl.iter (fun name w ->
+                Hashtbl.replace warnings name { w with status = w.default })
+    warnings
+
+let set_all_warnings_status status =
+  Hashtbl.iter (fun name w ->
+                Hashtbl.replace warnings name { w with status })
+    warnings
+
+let set_category_status ~name status =
+  let names = Hashtbl.find categories name in
+  List.iter (fun name -> set_warning_status name status) names
+
+let is_all_keyword name = CString.equal name "all"
+let is_none_keyword s = CString.equal s "none"
+
+let parse_flag s =
+  if String.length s > 1 then
+    match String.get s 0 with
+    | '+' -> (AsError, String.sub s 1 (String.length s - 1))
+    | '-' -> (Disabled, String.sub s 1 (String.length s - 1))
+    | _ -> (Enabled, s)
+  else CErrors.error "Invalid warnings flag"
+
+let string_of_flag (status,name) =
+  match status with
+  | AsError -> "+" ^ name
+  | Disabled -> "-" ^ name
+  | Enabled -> name
+
+let string_of_flags flags =
+  String.concat "," (List.map string_of_flag flags)
+
+let set_status ~name status =
+  if is_all_keyword name then
+    set_all_warnings_status status
+  else
+    try
+      set_category_status ~name status
+    with Not_found ->
+         try
+           set_warning_status ~name status
+         with Not_found -> ()
+
+let split_flags s =
+  let reg = Str.regexp "[ ,]+" in Str.split reg s
+
+let check_warning ~silent (_status,name) =
+  is_all_keyword name ||
+  Hashtbl.mem categories name ||
+  Hashtbl.mem warnings name ||
+  (if not silent then warn_unknown_warning name; false)
+
+(** [cut_before_all_rev] removes all flags subsumed by a later occurrence of the
+    "all" flag, and reverses the list. *)
+let rec cut_before_all_rev acc = function
+  | [] -> acc
+  | (_status,name as w) :: warnings ->
+     cut_before_all_rev (w :: if is_all_keyword name then [] else acc) warnings
+
+let cut_before_all_rev warnings = cut_before_all_rev [] warnings
+
+(** [uniquize_flags_rev] removes flags that are subsumed by later occurrences of
+    themselves or their categories, and reverses the list. *)
+let uniquize_flags_rev flags =
+  let rec aux acc visited = function
+    | (_,name as flag)::flags ->
+       if CString.Set.mem name visited then aux acc visited flags else
+         let visited =
+           try
+             let warnings = Hashtbl.find categories name in
+             List.fold_left (fun v w -> CString.Set.add w v) visited warnings
+           with Not_found ->
+             visited
+         in
+         aux (flag::acc) (CString.Set.add name visited) flags
+    | [] -> acc
+  in aux [] CString.Set.empty flags
+
+(** [normalize_flags] removes unknown or redundant warnings. If [silent] is
+    true, it emits a warning when an unknown warning is met. *)
+let normalize_flags ~silent warnings =
+  let warnings = List.filter (check_warning ~silent) warnings in
+  let warnings = cut_before_all_rev warnings in
+  uniquize_flags_rev warnings
+
+let flags_of_string s = List.map parse_flag (split_flags s)
+
+let normalize_flags_string s =
+  if is_none_keyword s then s
+  else
+    let flags = flags_of_string s in
+    let flags = normalize_flags ~silent:false flags in
+    string_of_flags flags
+
+let rec parse_warnings items =
+  CList.iter (fun (status, name) -> set_status ~name status) items
+
+(* For compatibility, we accept "none" *)
+let parse_flags s =
+  if is_none_keyword s then begin
+      Flags.make_warn false;
+      set_all_warnings_status Disabled;
+      "none"
+    end
+  else begin
+      Flags.make_warn true;
+      let flags = flags_of_string s in
+      let flags = normalize_flags ~silent:true flags in
+      parse_warnings flags;
+      string_of_flags flags
+    end
+
+let set_flags s =
+  reset_default_warnings (); let s = parse_flags s in flags := s
diff --git a/lib/cWarnings.mli b/lib/cWarnings.mli
new file mode 100644
index 00000000..3f6cee31
--- /dev/null
+++ b/lib/cWarnings.mli
@@ -0,0 +1,21 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+type status = Disabled | Enabled | AsError
+
+val set_current_loc : Loc.t -> unit
+
+val create : name:string -> category:string -> ?default:status ->
+             ('a -> Pp.std_ppcmds) -> ?loc:Loc.t -> 'a -> unit
+
+val get_flags : unit -> string
+val set_flags : string -> unit
+
+(** Cleans up a user provided warnings status string, e.g. removing unknown
+    warnings (in which case a warning is emitted) or subsumed warnings . *)
+val normalize_flags_string : string -> string
diff --git a/lib/clib.mllib b/lib/clib.mllib
index 9c9607ab..1e33173e 100644
--- a/lib/clib.mllib
+++ b/lib/clib.mllib
@@ -8,6 +8,7 @@ Hashcons
 CSet
 CMap
 Int
+Dyn
 HMap
 Option
 Store
@@ -20,20 +21,16 @@ Control
 Loc
 CList
 CString
-Serialize
 Deque
 CObj
 CArray
 CStack
 Util
 Stateid
-Feedback
 Pp
 Ppstyle
-Xml_lexer
-Xml_parser
-Xml_printer
 Richpp
+Feedback
 CUnix
 Envars
 Aux_file
diff --git a/lib/dyn.ml b/lib/dyn.ml
index 04b32870..65d1442a 100644
--- a/lib/dyn.ml
+++ b/lib/dyn.ml
@@ -6,12 +6,68 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
-open Pp
+module type TParam =
+sig
+  type 'a t
+end
 
+module type PreS =
+sig
+type 'a tag
+type t = Dyn : 'a tag * 'a -> t
+
+val create : string -> 'a tag
+val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option
+val repr : 'a tag -> string
+
+type any = Any : 'a tag -> any
+
+val name : string -> any option
+
+module Map(M : TParam) :
+sig
+  type t
+  val empty : t
+  val add : 'a tag -> 'a M.t -> t -> t
+  val remove : 'a tag -> t -> t
+  val find : 'a tag -> t -> 'a M.t
+  val mem : 'a tag -> t -> bool
+
+  type any = Any : 'a tag * 'a M.t -> any
+
+  type map = { map : 'a. 'a tag -> 'a M.t -> 'a M.t }
+  val map : map -> t -> t
+
+  val iter : (any -> unit) -> t -> unit
+  val fold : (any -> 'r -> 'r) -> t -> 'r -> 'r
+
+end
+
+val dump : unit -> (int * string) list
+
+end
+
+module type S =
+sig
+  include PreS
+
+  module Easy : sig
+    val make_dyn : string -> ('a -> t) * (t -> 'a)
+    val inj : 'a -> 'a tag -> t
+    val prj : t -> 'a tag -> 'a option
+  end
+
+end
+
+module Make(M : CSig.EmptyS) = struct
+module Self : PreS = struct
 (* Dynamics, programmed with DANGER !!! *)
 
-type t = int * Obj.t
+type 'a tag = int
+
+type t = Dyn : 'a tag * 'a -> t
+
+type any = Any : 'a tag -> any
 
 let dyntab = ref (Int.Map.empty : string Int.Map.t)
 (** Instead of working with tags as strings, which are costly, we use their
@@ -24,27 +80,69 @@ let create (s : string) =
   let () =
     if Int.Map.mem hash !dyntab then
       let old = Int.Map.find hash !dyntab in
-      let msg = str "Dynamic tag collision: " ++ str s ++ str " vs. " ++ str old in
-      anomaly ~label:"Dyn.create" msg
+      let () = Printf.eprintf "Dynamic tag collision: %s vs. %s\n%!" s old in
+      assert false
   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
-      anomaly (str "dyn_out: expected " ++ str s)
-  in
-  (infun, outfun)
+  hash
 
-let has_tag (s, _) tag =
-  let hash = Hashtbl.hash (tag : string) in
-  Int.equal s hash
+let eq : 'a 'b. 'a tag -> 'b tag -> ('a, 'b) CSig.eq option =
+  fun h1 h2 -> if Int.equal h1 h2 then Some (Obj.magic CSig.Refl) else None
 
-let tag (s,_) =
+let repr s =
   try Int.Map.find s !dyntab
   with Not_found ->
-    anomaly (str "Unknown dynamic tag " ++ int s)
+    let () = Printf.eprintf "Unknown dynamic tag %i\n%!" s in
+    assert false
 
-let pointer_equal (t1,o1) (t2,o2) = t1 = t2 && o1 == o2
+let name s =
+  let hash = Hashtbl.hash s in
+  if Int.Map.mem hash !dyntab then Some (Any hash) else None
 
 let dump () = Int.Map.bindings !dyntab
+
+module Map(M : TParam) =
+struct
+type t = Obj.t M.t Int.Map.t
+let cast : 'a M.t -> 'b M.t = Obj.magic
+let empty = Int.Map.empty
+let add tag v m = Int.Map.add tag (cast v) m
+let remove tag m = Int.Map.remove tag m
+let find tag m = cast (Int.Map.find tag m)
+let mem = Int.Map.mem
+
+type any = Any : 'a tag * 'a M.t -> any
+
+type map = { map : 'a. 'a tag -> 'a M.t -> 'a M.t }
+let map f m = Int.Map.mapi f.map m
+
+let iter f m = Int.Map.iter (fun k v -> f (Any (k, v))) m
+let fold f m accu = Int.Map.fold (fun k v accu -> f (Any (k, v)) accu) m accu
+end
+
+end
+include Self
+
+module Easy = struct
+(* now tags are opaque, we can do the trick *)
+let make_dyn (s : string) =
+ (fun (type a) (tag : a tag) ->
+  let infun : (a -> t) = fun x -> Dyn (tag, x) in
+  let outfun : (t -> a) = fun (Dyn (t, x)) ->
+    match eq tag t with
+    | None -> assert false
+    | Some CSig.Refl -> x
+  in
+  (infun, outfun))
+ (create s)
+
+let inj x tag = Dyn(tag,x)
+let prj : type a. t -> a tag -> a option =
+    fun (Dyn(tag',x)) tag ->
+    match eq tag tag' with
+    | None -> None
+    | Some CSig.Refl -> Some x
+end
+
+end
+
diff --git a/lib/dyn.mli b/lib/dyn.mli
index c040d8b0..448b11a1 100644
--- a/lib/dyn.mli
+++ b/lib/dyn.mli
@@ -6,12 +6,58 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(** Dynamics. Use with extreme care. Not for kids. *)
+(** Dynamically typed values *)
 
-type t
+module type TParam =
+sig
+  type 'a t
+end
+
+module type S =
+sig
+type 'a tag
+type t = Dyn : 'a tag * 'a -> t
+
+val create : string -> 'a tag
+val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option
+val repr : 'a tag -> string
+
+type any = Any : 'a tag -> any
+
+val name : string -> any option
+
+module Map(M : TParam) :
+sig
+  type t
+  val empty : t
+  val add : 'a tag -> 'a M.t -> t -> t
+  val remove : 'a tag -> t -> t
+  val find : 'a tag -> t -> 'a M.t
+  val mem : 'a tag -> t -> bool
+
+  type any = Any : 'a tag * 'a M.t -> any
+
+  type map = { map : 'a. 'a tag -> 'a M.t -> 'a M.t }
+  val map : map -> t -> t
+
+  val iter : (any -> unit) -> t -> unit
+  val fold : (any -> 'r -> 'r) -> t -> 'r -> 'r
+
+end
 
-val create : string -> ('a -> t) * (t -> 'a)
-val tag : t -> string
-val has_tag : t -> string -> bool
-val pointer_equal : t -> t -> bool
 val dump : unit -> (int * string) list
+
+module Easy : sig
+
+  (* To create a dynamic type on the fly *)
+  val make_dyn : string -> ('a -> t) * (t -> 'a)
+
+  (* For types declared with the [create] function above *)
+  val inj : 'a -> 'a tag -> t
+  val prj : t -> 'a tag -> 'a option
+end
+
+end
+
+(** FIXME: use OCaml 4.02 generative functors when available *)
+module Make(M : CSig.EmptyS) : S
diff --git a/lib/envars.ml b/lib/envars.ml
index 679e3fdf..89ce5283 100644
--- a/lib/envars.ml
+++ b/lib/envars.ml
@@ -146,23 +146,12 @@ let coqpath =
 
 let exe s = s ^ Coq_config.exec_extension
 
-let guess_camlbin () = which (user_path ()) (exe "ocamlc")
+let guess_ocamlfind () = which (user_path ()) (exe "ocamlfind")
 
-let camlbin () =
-  if !Flags.camlbin_spec then !Flags.camlbin else
-    if !Flags.boot then Coq_config.camlbin else
-      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
-  else
-    let _, res = CUnix.run_command (ocamlc () ^ " -where") in
-    String.strip res
+let ocamlfind () =
+  if !Flags.ocamlfind_spec then !Flags.ocamlfind else
+    if !Flags.boot then Coq_config.ocamlfind else
+      try guess_ocamlfind () / "ocamlfind"  with Not_found -> Coq_config.ocamlfind
 
 (** {2 Camlp4 paths} *)
 
@@ -173,9 +162,7 @@ let camlp4bin () =
     if !Flags.boot then Coq_config.camlp4bin else
       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
+        Coq_config.camlp4bin
 
 let camlp4 () = camlp4bin () / exe Coq_config.camlp4
 
@@ -183,7 +170,7 @@ let camlp4lib () =
   if !Flags.boot then
     Coq_config.camlp4lib
   else
-    let ex, res = CUnix.run_command (camlp4 () ^ " -where") in
+    let ex, res = CUnix.run_command (ocamlfind () ^ " query " ^ Coq_config.camlp4) in
     match ex with
       | Unix.WEXITED 0 -> String.strip res
       | _ -> "/dev/null"
diff --git a/lib/envars.mli b/lib/envars.mli
index d95b6f09..90a42859 100644
--- a/lib/envars.mli
+++ b/lib/envars.mli
@@ -47,17 +47,8 @@ val coqroot : string
     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
-
-(** [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
+(** [camlbin ()] is the path to the ocamlfind binary. *)
+val ocamlfind : unit -> string
 
 (** [camlp4bin ()] is the path to the camlp4 binary. *)
 val camlp4bin : unit -> string
diff --git a/lib/explore.ml b/lib/explore.ml
index 587db115..aa7bddf2 100644
--- a/lib/explore.ml
+++ b/lib/explore.ml
@@ -27,7 +27,7 @@ module Make = functor(S : SearchProblem) -> struct
       | [i] -> int i
       | i :: l -> pp_rec l ++ str "." ++ int i
     in
-    msg_debug (h 0 (pp_rec p) ++ pp)
+    Feedback.msg_debug (h 0 (pp_rec p) ++ pp)
 
   (*s Depth first search. *)
 
diff --git a/lib/feedback.ml b/lib/feedback.ml
index cce0c6bc..44b3ee35 100644
--- a/lib/feedback.ml
+++ b/lib/feedback.ml
@@ -7,51 +7,14 @@
 (************************************************************************)
 
 open Xml_datatype
-open Serialize
 
-type message_level =
-  | Debug of string
+type level =
+  | Debug
   | 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
@@ -61,7 +24,6 @@ type feedback_content =
   | Processed
   | Incomplete
   | Complete
-  | ErrorMsg of Loc.t * string
   | ProcessingIn of string
   | InProgress of int
   | WorkerStatus of string * string
@@ -71,8 +33,10 @@ type feedback_content =
   | GlobDef of Loc.t * string * string * string
   | FileDependency of string option * string
   | FileLoaded of string * string
+  (* Extra metadata *)
   | Custom of Loc.t * string * xml
-  | Message of message
+  (* Generic messages *)
+  | Message of level * Loc.t option * Richpp.richpp
 
 type feedback = {
   id : edit_or_state_id;
@@ -80,92 +44,189 @@ type feedback = {
   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
+
+(** Feedback and logging *)
+open Pp
+open Pp_control
+
+type logger = ?loc:Loc.t -> level -> std_ppcmds -> unit
+
+let msgnl_with ?pp_tag fmt strm = msg_with ?pp_tag fmt (strm ++ fnl ())
+
+(* XXX: This is really painful! *)
+module Emacs = struct
+
+  (* 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_err g =
+    hov 0 (str emacs_quote_start ++ g ++ str emacs_quote_end)
+
+  let emacs_quote_info_start = "<infomsg>"
+  let emacs_quote_info_end = "</infomsg>"
+
+  let emacs_quote_info g =
+    hov 0 (str emacs_quote_info_start++ brk(0,0) ++ g ++ brk(0,0) ++ str emacs_quote_info_end)
+
+end
+
+open Emacs
+
+let  dbg_str = tag Ppstyle.(Tag.inj debug_tag   tag) (str "Debug:")   ++ spc ()
+let info_str = mt ()
+let warn_str = tag Ppstyle.(Tag.inj warning_tag tag) (str "Warning:") ++ spc ()
+let  err_str = tag Ppstyle.(Tag.inj error_tag   tag) (str "Error:"  ) ++ spc ()
+
+let make_body quoter info ?loc s =
+  let loc = Option.cata Pp.pr_loc (Pp.mt ()) loc in
+  quoter (hov 0 (loc ++ info ++ s))
+
+(* Generic logger *)
+let gen_logger dbg err ?pp_tag ?loc level msg = match level with
+  | Debug   -> msgnl_with ?pp_tag !std_ft (make_body dbg  dbg_str ?loc msg)
+  | Info    -> msgnl_with ?pp_tag !std_ft (make_body dbg info_str ?loc msg)
+  | Notice  -> msgnl_with ?pp_tag !std_ft msg
+  | Warning -> Flags.if_warn (fun () ->
+               msgnl_with ?pp_tag !err_ft (make_body err warn_str ?loc msg)) ()
+  | Error   -> msgnl_with ?pp_tag !err_ft (make_body err  err_str ?loc msg)
+
+(* We provide a generic clear_log_backend callback for backends
+   wanting to do clenaup after the print.
+*)
+let std_logger_tag     = ref None
+let std_logger_cleanup = ref (fun () -> ())
+
+let std_logger ?loc level msg =
+  gen_logger (fun x -> x) (fun x -> x) ?pp_tag:!std_logger_tag ?loc level msg;
+  !std_logger_cleanup ()
+
+(* Rules for emacs:
+   - Debug/info: emacs_quote_info
+   - Warning/Error: emacs_quote_err
+   - Notice: unquoted
+
+  Note the inconsistency.
+ *)
+let emacs_logger = gen_logger emacs_quote_info emacs_quote_err ?pp_tag:None
+
+(** Color logging. Moved from pp_style, it may need some more refactoring  *)
+
+(** Not thread-safe. We should put a lock somewhere if we print from
+    different threads. Do we? *)
+let make_style_stack () =
+  (** Default tag is to reset everything *)
+  let empty = Terminal.make () in
+  let default_tag = Terminal.({
+      fg_color = Some `DEFAULT;
+      bg_color = Some `DEFAULT;
+      bold = Some false;
+      italic = Some false;
+      underline = Some false;
+      negative = Some false;
+    })
+  in
+  let style_stack = ref [] in
+  let peek () = match !style_stack with
+  | []      -> default_tag  (** Anomalous case, but for robustness *)
+  | st :: _ -> st
+  in
+  let push tag =
+    let style = match Ppstyle.get_style tag with
+      | None    -> empty
+      | Some st -> st
+    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
+    style_stack := style :: !style_stack;
+    Terminal.eval style
+  in
+  let pop _ = match !style_stack with
+  | []       -> (** Something went wrong, we fallback *)
+                Terminal.eval default_tag
+  | _ :: rem -> style_stack := rem;
+                Terminal.eval (peek ())
+  in
+  let clear () = style_stack := [] in
+  push, pop, clear
+
+let init_color_output () =
+  let open Pp_control in
+  let push_tag, pop_tag, clear_tag = make_style_stack () in
+  std_logger_cleanup := clear_tag;
+  std_logger_tag     := Some Ppstyle.pp_tag;
+  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
+  Format.pp_set_mark_tags !std_ft true;
+  Format.pp_set_mark_tags !err_ft true;
+  Format.pp_set_formatter_tag_functions !std_ft tag_handler;
+  Format.pp_set_formatter_tag_functions !err_ft tag_handler
+
+let logger       = ref std_logger
+let set_logger l = logger := l
+
+let msg_info    ?loc x = !logger ?loc Info x
+let msg_notice  ?loc x = !logger ?loc Notice x
+let msg_warning ?loc x = !logger ?loc Warning x
+let msg_error   ?loc x = !logger ?loc Error x
+let msg_debug   ?loc x = !logger ?loc Debug x
+
+(** Feeders *)
+let feeders = ref []
+let add_feeder f = feeders := f :: !feeders
+
+let debug_feeder = function
+  | { contents = Message (Debug, loc, pp) } ->
+       msg_debug ?loc (Pp.str (Richpp.raw_print pp))
+  | _ -> ()
+
+let feedback_id    = ref (Edit 0)
+let feedback_route = ref default_route
+
+let set_id_for_feedback ?(route=default_route) i =
+  feedback_id := i; feedback_route := route
+
+let feedback ?id ?route what =
+  let m = {
+     contents = what;
+     route = Option.default !feedback_route route;
+     id    = Option.default !feedback_id id;
+  } in
+  List.iter (fun f -> f m) !feeders
+
+let feedback_logger ?loc lvl msg =
+  feedback ~route:!feedback_route ~id:!feedback_id
+    (Message (lvl, loc, Richpp.richpp_of_pp msg))
+
+(* Output to file *)
+let ft_logger old_logger ft ?loc level mesg =
+  let id x = x in
+  match level with
+  | Debug   -> msgnl_with ft (make_body id  dbg_str mesg)
+  | Info    -> msgnl_with ft (make_body id info_str mesg)
+  | Notice  -> msgnl_with ft mesg
+  | Warning -> old_logger ?loc level mesg
+  | Error   -> old_logger ?loc level mesg
+
+let with_output_to_file fname func input =
+  let old_logger = !logger in
+  let channel = open_out (String.concat "." [fname; "out"]) in
+  logger := ft_logger old_logger (Format.formatter_of_out_channel channel);
+  try
+    let output = func input in
+    logger := old_logger;
+    close_out channel;
+    output
+  with reraise ->
+    let reraise = Backtrace.add_backtrace reraise in
+    logger := old_logger;
+    close_out channel;
+    Exninfo.iraise reraise
+
diff --git a/lib/feedback.mli b/lib/feedback.mli
index 16286762..5160bd5b 100644
--- a/lib/feedback.mli
+++ b/lib/feedback.mli
@@ -9,27 +9,19 @@
 open Xml_datatype
 
 (* Old plain messages (used to be in Pp) *)
-type message_level =
-  | Debug of string
+type level =
+  | Debug
   | 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
@@ -39,7 +31,6 @@ type feedback_content =
   | Processed
   | Incomplete
   | Complete
-  | ErrorMsg of Loc.t * string
   (* STM optional data *)
   | ProcessingIn of string
   | InProgress of int
@@ -53,16 +44,89 @@ type feedback_content =
   | FileLoaded of string * string
   (* Extra metadata *)
   | Custom of Loc.t * string * xml
-  (* Old generic messages *)
-  | Message of message
+  (* Generic messages *)
+  | Message of level * Loc.t option * Richpp.richpp
 
 type feedback = {
-  id : edit_or_state_id;       (* The document part concerned *)
+  id       : edit_or_state_id;  (* The document part concerned *)
   contents : feedback_content;  (* The payload *)
-  route : route_id;            (* Extra routing info *)
+  route    : route_id;          (* Extra routing info *)
 }
 
-val of_feedback : feedback -> xml
-val to_feedback : xml -> feedback
-val is_feedback : xml -> bool
+(** {6 Feedback sent, even asynchronously, to the user interface} *)
+
+(** Moved here from pp.ml *)
+
+(* 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. *)
+
+(** A [logger] takes a level plus a pretty printing doc and logs it *)
+type logger = ?loc:Loc.t -> level -> Pp.std_ppcmds -> unit
+
+(** [set_logger l] makes the [msg_*] to use [l] for logging *)
+val set_logger : logger -> unit
+
+(** [std_logger] standard logger to [stdout/stderr]  *)
+val std_logger : logger
+
+(** [init_color_output ()] Enable color in the std_logger *)
+val init_color_output : unit -> unit
+
+(** [feedback_logger] will produce feedback messages instead IO events *)
+val feedback_logger : logger
+val emacs_logger    : logger
+
+
+(** [add_feeder] feeders observe the feedback *)
+val add_feeder : (feedback -> unit) -> unit
+
+(** Prints feedback messages of kind Message(Debug,_) using msg_debug *)
+val debug_feeder : feedback -> unit
+
+(** [feedback ?id ?route fb] produces feedback fb, with [route] and
+    [id] set appropiatedly, if absent, it will use the defaults set by
+    [set_id_for_feedback] *)
+val feedback :
+  ?id:edit_or_state_id -> ?route:route_id -> feedback_content -> unit
+
+(** [set_id_for_feedback route id] Set the defaults for feedback *)
+val set_id_for_feedback : ?route:route_id -> edit_or_state_id -> unit
+
+(** [with_output_to_file file f x] executes [f x] with logging
+    redirected to a file [file] *)
+val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b
+
+(** {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 : ?loc:Loc.t -> Pp.std_ppcmds -> unit
+(** Message that displays information, usually in verbose mode, such as [Foobar
+    is defined] *)
+
+val msg_notice : ?loc:Loc.t -> Pp.std_ppcmds -> unit
+(** Message that should be displayed, such as [Print Foo] or [Show Bar]. *)
+
+val msg_warning : ?loc:Loc.t -> Pp.std_ppcmds -> unit
+(** Message indicating that something went wrong, but without serious
+    consequences. *)
+
+val msg_error : ?loc:Loc.t -> Pp.std_ppcmds -> unit
+(** Message indicating that something went really wrong, though still
+    recoverable; otherwise an exception would have been raised. *)
+
+val msg_debug : ?loc:Loc.t -> Pp.std_ppcmds -> unit
+(** For debugging purposes *)
+
+
+
 
diff --git a/lib/flags.ml b/lib/flags.ml
index 2c23ec98..0e2f7e5a 100644
--- a/lib/flags.ml
+++ b/lib/flags.ml
@@ -47,6 +47,7 @@ let batch_mode = ref false
 
 type compilation_mode = BuildVo | BuildVio | Vio2Vo
 let compilation_mode = ref BuildVo
+let compilation_output_name = ref None
 
 let test_mode = ref false
 
@@ -68,11 +69,15 @@ let priority_of_string = function
   | "low" -> Low
   | "high" -> High
   | _ -> raise (Invalid_argument "priority_of_string")
+type tac_error_filter = [ `None | `Only of string list | `All ]
+let async_proofs_tac_error_resilience = ref (`Only [ "curly" ])
+let async_proofs_cmd_error_resilience = ref true
 
 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 async_proofs_delegation_threshold = ref 0.03
 
 let debug = ref false
 let in_debugger = ref false
@@ -103,31 +108,37 @@ let we_are_parsing = ref false
 (* Current means no particular compatibility consideration.
    For correct comparisons, this constructor should remain the last one. *)
 
-type compat_version = V8_2 | V8_3 | V8_4 | Current
+type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | Current
 
 let compat_version = ref Current
 
-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_compare v1 v2 = match v1, v2 with
+| V8_2, V8_2 -> 0
+| V8_2, (V8_3 | V8_4 | V8_5 | Current) -> -1
+| V8_3, V8_2 -> 1
+| V8_3, V8_3 -> 0
+| V8_3, (V8_4 | V8_5 | Current) -> -1
+| V8_4, (V8_2 | V8_3) -> 1
+| V8_4, V8_4 -> 0
+| V8_4, (V8_5 | Current) -> -1
+| V8_5, (V8_2 | V8_3 | V8_4) -> 1
+| V8_5, V8_5 -> 0
+| V8_5, Current -> -1
+| Current, Current -> 0
+| Current, (V8_2 | V8_3 | V8_4 | V8_5) -> 1
+
+let version_strictly_greater v = version_compare !compat_version v > 0
 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"
+  | V8_5 -> "8.5"
   | Current -> "current"
 
 (* Translate *)
 let beautify = ref false
-let make_beautify f = beautify := f
-let do_beautify () = !beautify
 let beautify_file = ref false
 
 (* Silent / Verbose *)
@@ -164,7 +175,7 @@ let make_polymorphic_flag b =
 let program_mode = ref false
 let is_program_mode () = !program_mode
 
-let warn = ref false
+let warn = ref true
 let make_warn flag = warn := flag;  ()
 let if_warn f x = if !warn then f x
 
@@ -195,9 +206,9 @@ let is_standard_doc_url url =
 let coqlib_spec = ref false
 let coqlib = ref "(not initialized yet)"
 
-(* Options for changing camlbin (used by coqmktop) *)
-let camlbin_spec = ref false
-let camlbin = ref Coq_config.camlbin
+(* Options for changing ocamlfind (used by coqmktop) *)
+let ocamlfind_spec = ref false
+let ocamlfind = ref Coq_config.camlbin
 
 (* Options for changing camlp4bin (used by coqmktop) *)
 let camlp4bin_spec = ref false
@@ -217,6 +228,8 @@ let native_compiler = ref false
 let print_mod_uid = ref false
 
 let tactic_context_compat = ref false
+let profile_ltac = ref false
+let profile_ltac_cutoff = ref 2.0
 
 let dump_bytecode = ref false
 let set_dump_bytecode = (:=) dump_bytecode
diff --git a/lib/flags.mli b/lib/flags.mli
index ab06eda3..89760264 100644
--- a/lib/flags.mli
+++ b/lib/flags.mli
@@ -14,6 +14,7 @@ val load_init : bool ref
 val batch_mode : bool ref
 type compilation_mode = BuildVo | BuildVio | Vio2Vo
 val compilation_mode : compilation_mode ref
+val compilation_output_name : string option ref
 
 val test_mode : bool ref
 
@@ -34,6 +35,10 @@ type priority = Low | High
 val async_proofs_worker_priority : priority ref
 val string_of_priority : priority -> string
 val priority_of_string : string -> priority
+type tac_error_filter = [ `None | `Only of string list | `All ]
+val async_proofs_tac_error_resilience : tac_error_filter ref
+val async_proofs_cmd_error_resilience : bool ref
+val async_proofs_delegation_threshold : float ref
 
 val debug : bool ref
 val in_debugger : bool ref
@@ -57,15 +62,14 @@ val raw_print : bool ref
 val record_print : bool ref
 val univ_print : bool ref
 
-type compat_version = V8_2 | V8_3 | V8_4 | Current
+type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | Current
 val compat_version : compat_version ref
+val version_compare : compat_version -> compat_version -> int
 val version_strictly_greater : compat_version -> bool
 val version_less_or_equal : compat_version -> bool
 val pr_version : compat_version -> string
 
 val beautify : bool ref
-val make_beautify : bool -> unit
-val do_beautify : unit -> bool
 val beautify_file : bool ref
 
 val make_silent : bool -> unit
@@ -90,6 +94,7 @@ val is_universe_polymorphism : unit -> bool
 val make_polymorphic_flag : bool -> unit
 val use_polymorphic_flag : unit -> bool
 
+val warn : bool ref
 val make_warn : bool -> unit
 val if_warn : ('a -> unit) -> 'a -> unit
 
@@ -122,8 +127,8 @@ val coqlib_spec : bool ref
 val coqlib : string ref
 
 (** Options for specifying where OCaml binaries reside *)
-val camlbin_spec : bool ref
-val camlbin : string ref
+val ocamlfind_spec : bool ref
+val ocamlfind : string ref
 val camlp4bin_spec : bool ref
 val camlp4bin : string ref
 
@@ -142,6 +147,9 @@ val tactic_context_compat : bool ref
 (** Set to [true] to trigger the compatibility bugged context matching (old
     context vs. appcontext) is set. *)
 
+val profile_ltac : bool ref
+val profile_ltac_cutoff : float ref
+
 (** Dump the bytecode after compilation (for debugging purposes) *)
 val dump_bytecode : bool ref
 val set_dump_bytecode : bool -> unit
diff --git a/lib/future.ml b/lib/future.ml
index 5cd2beba..ea0382a6 100644
--- a/lib/future.ml
+++ b/lib/future.ml
@@ -7,8 +7,9 @@
 (************************************************************************)
 
 (* 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)
+type freeze
+let freeze = ref (fun () -> assert false : unit -> freeze)
+let unfreeze = ref (fun _ -> () : freeze -> unit)
 let set_freeze f g = freeze := f; unfreeze := g
 
 let not_ready_msg = ref (fun name ->
@@ -29,10 +30,10 @@ let customize_not_here_msg f = not_here_msg := f
 
 exception NotReady of string
 exception NotHere of string
-let _ = Errors.register_handler (function
+let _ = CErrors.register_handler (function
   | NotReady name -> !not_ready_msg name
   | NotHere name -> !not_here_msg name
-  | _ -> raise Errors.Unhandled)
+  | _ -> raise CErrors.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
@@ -58,11 +59,11 @@ type 'a assignement = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computat
 and 'a comp =
   | Delegated of (unit -> unit)
   | Closure of (unit -> 'a)
-  | Val of 'a * Dyn.t option
+  | Val of 'a * freeze option
   | Exn of Exninfo.iexn  (* Invariant: this exception is always "fixed" as in fix_exn *)
 
 and 'a comput =
-  | Ongoing of string * (UUID.t * fix_exn * 'a comp ref) Ephemeron.key
+  | Ongoing of string * (UUID.t * fix_exn * 'a comp ref) CEphemeron.key
   | Finished of 'a
 
 and 'a computation = 'a comput ref
@@ -70,13 +71,13 @@ and 'a computation = 'a comput ref
 let unnamed = "unnamed"
 
 let create ?(name=unnamed) ?(uuid=UUID.fresh ()) f x =
-  ref (Ongoing (name, Ephemeron.create (uuid, f, Pervasives.ref x)))
+  ref (Ongoing (name, CEphemeron.create (uuid, f, Pervasives.ref x)))
 let get x =
   match !x with
   | Finished v -> unnamed, UUID.invalid, id, ref (Val (v,None))
   | Ongoing (name, x) ->
-      try let uuid, fix, c = Ephemeron.get x in name, uuid, fix, c
-      with Ephemeron.InvalidKey ->
+      try let uuid, fix, c = CEphemeron.get x in name, uuid, fix, c
+      with CEphemeron.InvalidKey ->
         name, UUID.invalid, id, ref (Exn (NotHere name, Exninfo.null))
 
 type 'a value = [ `Val of 'a | `Exn of Exninfo.iexn  ]
@@ -135,7 +136,7 @@ let rec compute ~pure ck : 'a value =
         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 = CErrors.push e in
         let e = fix_exn e in
         match e with
         | (NotReady _, _) -> `Exn e
@@ -155,9 +156,9 @@ let chain ~pure ck f =
   | Val (v, Some state) -> Closure (fun () -> !unfreeze state; f v)
   | Val (v, None) ->
       match !ck with
-      | Finished _ -> Errors.anomaly(Pp.str
+      | Finished _ -> CErrors.anomaly(Pp.str
           "Future.chain ~pure:false call on an already joined computation")
-      | Ongoing _ -> Errors.anomaly(Pp.strbrk(
+      | Ongoing _ -> CErrors.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 "^
@@ -169,7 +170,7 @@ let replace kx y =
   let _, _, _, x = get kx in
   match !x with
   | Exn _ -> x := Closure (fun () -> force ~pure:false y)
-  | _ -> Errors.anomaly
+  | _ -> CErrors.anomaly
            (Pp.str "A computation can be replaced only if is_exn holds")
 
 let purify f x =
@@ -179,13 +180,13 @@ let purify f x =
     !unfreeze state;
     v
   with e ->
-    let e = Errors.push e in !unfreeze state; Exninfo.iraise e
+    let e = CErrors.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 e = CErrors.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
@@ -212,7 +213,7 @@ let map2 ?greedy f x l =
     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
+          CErrors.anomaly (Pp.str "Future.map2 length mismatch")) in
     f xi y) 0 l
 
 let print f kx =
diff --git a/lib/future.mli b/lib/future.mli
index 58f0a71a..114c5917 100644
--- a/lib/future.mli
+++ b/lib/future.mli
@@ -157,10 +157,11 @@ 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
 
+type freeze
 (* 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
+val set_freeze : (unit -> freeze) -> (freeze -> unit) -> unit
 
 val customize_not_ready_msg : (string -> Pp.std_ppcmds) -> unit
 val customize_not_here_msg : (string -> Pp.std_ppcmds) -> unit
diff --git a/lib/genarg.ml b/lib/genarg.ml
index cba54c11..05c828d5 100644
--- a/lib/genarg.ml
+++ b/lib/genarg.ml
@@ -9,168 +9,160 @@
 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
+module ArgT =
+struct
+  module DYN = Dyn.Make(struct end)
+  module Map = DYN.Map
+  type ('a, 'b, 'c) tag = ('a * 'b * 'c) DYN.tag
+  type any = Any : ('a, 'b, 'c) tag -> any
+  let eq = DYN.eq
+  let repr = DYN.repr
+  let create = DYN.create
+  let name s = match DYN.name s with
+  | None -> None
+  | Some (DYN.Any t) ->
+    Some (Any (Obj.magic t)) (** All created tags are made of triples *)
+end
+
+type (_, _, _) genarg_type =
+| ExtraArg : ('a, 'b, 'c) ArgT.tag -> ('a, 'b, 'c) genarg_type
+| ListArg : ('a, 'b, 'c) genarg_type -> ('a list, 'b list, 'c list) genarg_type
+| OptArg : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) genarg_type
+| PairArg : ('a1, 'b1, 'c1) genarg_type * ('a2, 'b2, 'c2) genarg_type ->
+  ('a1 * 'a2, 'b1 * 'b2, 'c1 * 'c2) genarg_type
+
+type argument_type = ArgumentType : ('a, 'b, 'c) genarg_type -> argument_type
+
+let rec genarg_type_eq : type a1 a2 b1 b2 c1 c2.
+  (a1, b1, c1) genarg_type -> (a2, b2, c2) genarg_type ->
+  (a1 * b1 * c1, a2 * b2 * c2) CSig.eq option =
+fun t1 t2 -> match t1, t2 with
+| ExtraArg t1, ExtraArg t2 -> ArgT.eq t1 t2
+| ListArg t1, ListArg t2 ->
+  begin match genarg_type_eq t1 t2 with
+  | None -> None
+  | Some Refl -> Some Refl
+  end
+| OptArg t1, OptArg t2 ->
+  begin match genarg_type_eq t1 t2 with
+  | None -> None
+  | Some Refl -> Some Refl
+  end
+| PairArg (t1, u1), PairArg (t2, u2) ->
+  begin match genarg_type_eq t1 t2 with
+  | None -> None
+  | Some Refl ->
+    match genarg_type_eq u1 u2 with
+    | None -> None
+    | Some Refl -> Some Refl
+  end
+| _ -> None
+
+let rec pr_genarg_type : type a b c. (a, b, c) genarg_type -> std_ppcmds = function
+| ListArg t -> pr_genarg_type t ++ spc () ++ str "list"
+| OptArg t -> pr_genarg_type t ++ spc () ++ str "opt"
+| PairArg (t1, t2) ->
+    str "("++ pr_genarg_type t1 ++ spc () ++
+    str "*" ++ spc () ++ pr_genarg_type t2 ++ str ")"
+| ExtraArg s -> str (ArgT.repr s)
+
+let argument_type_eq arg1 arg2 = match arg1, arg2 with
+| ArgumentType t1, ArgumentType t2 ->
+  match genarg_type_eq t1 t2 with
+  | None -> false
+  | Some Refl -> true
+
+let pr_argument_type (ArgumentType t) = pr_genarg_type t
 
 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 rlevel = [ `rlevel ]
+type glevel = [ `glevel ]
+type tlevel = [ `tlevel ]
+
+type (_, _) abstract_argument_type =
+| Rawwit : ('a, 'b, 'c) genarg_type -> ('a, rlevel) abstract_argument_type
+| Glbwit : ('a, 'b, 'c) genarg_type -> ('b, glevel) abstract_argument_type
+| Topwit : ('a, 'b, 'c) genarg_type -> ('c, tlevel) abstract_argument_type
+
+type 'l generic_argument = GenArg : ('a, 'l) abstract_argument_type * 'a -> 'l generic_argument
 
-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 rawwit t = Rawwit t
+let glbwit t = Glbwit t
+let topwit t = Topwit t
+
+let wit_list t = ListArg t
+
+let wit_opt t = OptArg t
+
+let wit_pair t1 t2 = PairArg (t1, t2)
+
+let in_gen t o = GenArg (t, o)
+
+let abstract_argument_type_eq :
+  type a b l. (a, l) abstract_argument_type -> (b, l) abstract_argument_type -> (a, b) CSig.eq option =
+  fun t1 t2 -> match t1, t2 with
+  | Rawwit t1, Rawwit t2 ->
+    begin match genarg_type_eq t1 t2 with
+    | None -> None
+    | Some Refl -> Some Refl
+    end
+  | Glbwit t1, Glbwit t2 ->
+    begin match genarg_type_eq t1 t2 with
+    | None -> None
+    | Some Refl -> Some Refl
+    end
+  | Topwit t1, Topwit t2 ->
+    begin match genarg_type_eq t1 t2 with
+    | None -> None
+    | Some Refl -> Some Refl
+    end
+
+let out_gen (type a) (type l) (t : (a, l) abstract_argument_type) (o : l generic_argument) : a =
+  let GenArg (t', v) = o in
+  match abstract_argument_type_eq t t' with
+  | None -> failwith "out_gen"
+  | Some Refl -> v
+
+let has_type (GenArg (t, v)) u = match abstract_argument_type_eq t u with
+| None -> false
+| Some _ -> true
+
+let unquote : type l. (_, l) abstract_argument_type -> _ = function
+| Rawwit t -> ArgumentType t
+| Glbwit t -> ArgumentType t
+| Topwit t -> ArgumentType t
+
+let genarg_tag (GenArg (t, _)) = unquote 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
+module type Param = sig type ('raw, 'glb, 'top) t end
+module ArgMap(M : Param) =
+struct
+  type _ pack = Pack : ('raw, 'glb, 'top) M.t -> ('raw * 'glb * 'top) pack
+  include ArgT.Map(struct type 'a t = 'a pack end)
+end
 
-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 create_arg name =
+  match ArgT.name name with
+  | None -> ExtraArg (ArgT.create name)
+  | Some _ ->
+    CErrors.anomaly (str "generic argument already declared: " ++ str 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 =
@@ -182,54 +174,31 @@ end
 
 module Register (M : GenObj) =
 struct
-  let arg0_map =
-    ref (String.Map.empty : (Obj.t, Obj.t, Obj.t) M.obj String.Map.t)
+  module GenMap = ArgMap(struct type ('r, 'g, 't) t = ('r, 'g, 't) M.obj end)
+  let arg0_map = ref GenMap.empty
 
   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
+  | ExtraArg s ->
+    if GenMap.mem s !arg0_map then
+      let msg = str M.name ++ str " function already registered: " ++ str (ArgT.repr s) in
+      CErrors.anomaly msg
     else
-      arg0_map := String.Map.add s (Obj.magic f) !arg0_map
+      arg0_map := GenMap.add s (GenMap.Pack f) !arg0_map
   | _ -> assert false
 
   let get_obj0 name =
-    try String.Map.find name !arg0_map
+    try
+      let GenMap.Pack obj = GenMap.find name !arg0_map in obj
     with Not_found ->
-      match M.default (ExtraArgType name) with
+      match M.default (ExtraArg name) with
       | None ->
-        Errors.anomaly (str M.name ++ str " function not found: " ++ str name)
+        CErrors.anomaly (str M.name ++ str " function not found: " ++ str (ArgT.repr 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)
+  | ExtraArg s -> 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
index 671d96b7..d7ad9b93 100644
--- a/lib/genarg.mli
+++ b/lib/genarg.mli
@@ -6,6 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(** Generic arguments used by the extension mechanisms of several Coq ASTs. *)
+
 (** The route of a generic argument, from parsing to evaluation.
 In the following diagram, "object" can be tactic_expr, constr, tactic_arg, etc.
 
@@ -34,69 +36,57 @@ In the following diagram, "object" can be tactic_expr, constr, tactic_arg, etc.
 effective use
 {% \end{%}verbatim{% }%}
 
-To distinguish between the uninterpreted (raw), globalized and
+To distinguish between the uninterpreted, globalized and
 interpreted worlds, we annotate the type [generic_argument] by a
-phantom argument which is either [constr_expr], [glob_constr] or
-[constr].
+phantom argument.
 
-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. *)
+module ArgT :
+sig
+  type ('a, 'b, 'c) tag
+  val eq : ('a1, 'b1, 'c1) tag -> ('a2, 'b2, 'c2) tag -> ('a1 * 'b1 * 'c1, 'a2 * 'b2 * 'c2) CSig.eq option
+  val repr : ('a, 'b, 'c) tag -> string
+  type any = Any : ('a, 'b, 'c) tag -> any
+  val name : string -> any option
+end
+
+(** Generic types. The first parameter is the OCaml lowest level, the second one
+    is the globalized level, and third one the internalized level. *)
+type (_, _, _) genarg_type =
+| ExtraArg : ('a, 'b, 'c) ArgT.tag -> ('a, 'b, 'c) genarg_type
+| ListArg : ('a, 'b, 'c) genarg_type -> ('a list, 'b list, 'c list) genarg_type
+| OptArg : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) genarg_type
+| PairArg : ('a1, 'b1, 'c1) genarg_type * ('a2, 'b2, 'c2) genarg_type ->
+  ('a1 * 'a2, 'b1 * 'b2, 'c1 * 'c2) genarg_type
 
 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
+val make0 : 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
+val create_arg : 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
-*)
+    to ensure the injectivity of the GADT type inference. *)
 
-type rlevel
-type glevel
-type tlevel
+type rlevel = [ `rlevel ]
+type glevel = [ `glevel ]
+type tlevel = [ `tlevel ]
 
-type ('a, 'co) abstract_argument_type
-(** Type at level ['co] represented by an OCaml value of type ['a]. *)
+(** Generic types at a fixed level. The first parameter embeds the OCaml type
+    and the second one the level. *)
+type (_, _) abstract_argument_type =
+| Rawwit : ('a, 'b, 'c) genarg_type -> ('a, rlevel) abstract_argument_type
+| Glbwit : ('a, 'b, 'c) genarg_type -> ('b, glevel) abstract_argument_type
+| Topwit : ('a, 'b, 'c) genarg_type -> ('c, tlevel) abstract_argument_type
 
 type 'a raw_abstract_argument_type = ('a, rlevel) abstract_argument_type
 (** Specialized type at raw level. *)
@@ -120,7 +110,7 @@ val topwit : ('a, 'b, 'c) genarg_type -> ('c, tlevel) abstract_argument_type
 
 (** {5 Generic arguments} *)
 
-type 'a generic_argument
+type 'l generic_argument = GenArg : ('a, 'l) abstract_argument_type * 'a -> 'l generic_argument
 (** A inhabitant of ['level generic_argument] is a inhabitant of some type at
     level ['level], together with the representation of this type. *)
 
@@ -141,66 +131,20 @@ 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
+type argument_type = ArgumentType : ('a, 'b, 'c) genarg_type -> argument_type
+
+(** {6 Equalities} *)
 
 val argument_type_eq : argument_type -> argument_type -> bool
+val genarg_type_eq :
+  ('a1, 'b1, 'c1) genarg_type ->
+  ('a2, 'b2, 'c2) genarg_type ->
+  ('a1 * 'b1 * 'c1, 'a2 * 'b2 * 'c2) CSig.eq option
+val abstract_argument_type_eq :
+  ('a, 'l) abstract_argument_type -> ('b, 'l) abstract_argument_type ->
+  ('a, 'b) CSig.eq option
 
 val pr_argument_type : argument_type -> Pp.std_ppcmds
 (** Print a human-readable representation for a given type. *)
@@ -236,43 +180,13 @@ sig
 
 end
 
-(** {5 Basic generic type constructors} *)
+(** {5 Compatibility layer}
 
-(** {6 Parameterized types} *)
+The functions below are aliases for generic_type constructors.
+
+*)
 
 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/hMap.ml b/lib/hMap.ml
index ba6aad91..ea76e742 100644
--- a/lib/hMap.ml
+++ b/lib/hMap.ml
@@ -68,34 +68,91 @@ struct
         Int.Map.update h m s
     with Not_found -> s
 
+  let height s = Int.Map.height s
+
+  let is_smaller s1 s2 = height s1 <= height s2 + 3
+
+  (** Assumes s1 << s2 *)
+  let fast_union s1 s2 =
+    let fold h s accu =
+      try Int.Map.modify h (fun _ s' -> Set.fold Set.add s s') accu
+      with Not_found -> Int.Map.add h s accu
+    in
+    Int.Map.fold fold s1 s2
+
   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)
+    if is_smaller s1 s2 then fast_union s1 s2
+    else if is_smaller s2 s1 then fast_union s2 s1
+    else
+      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
+
+  (** Assumes s1 << s2 *)
+  let fast_inter s1 s2 =
+    let fold h s accu =
+      try
+        let s' = Int.Map.find h s2 in
+        let si = Set.filter (fun e -> Set.mem e s') s in
+        if Set.is_empty si then accu
+        else Int.Map.add h si accu
+     with Not_found -> accu
     in
-    Int.Map.merge fu s1 s2
+    Int.Map.fold fold s1 Int.Map.empty
 
   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
+    if is_smaller s1 s2 then fast_inter s1 s2
+    else if is_smaller s2 s1 then fast_inter s2 s1
+    else
+      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
+
+  (** Assumes s1 << s2 *)
+  let fast_diff_l s1 s2 =
+    let fold h s accu =
+      try
+        let s' = Int.Map.find h s2 in
+        let si = Set.filter (fun e -> not (Set.mem e s')) s in
+        if Set.is_empty si then accu
+        else Int.Map.add h si accu
+     with Not_found -> Int.Map.add h s accu
     in
-    Int.Map.merge fu s1 s2
+    Int.Map.fold fold s1 Int.Map.empty
+
+  (** Assumes s2 << s1 *)
+  let fast_diff_r s1 s2 =
+    let fold h s accu =
+      try
+        let s' = Int.Map.find h accu in
+        let si = Set.filter (fun e -> not (Set.mem e s)) s' in
+        if Set.is_empty si then Int.Map.remove h accu
+        else Int.Map.update h si accu
+     with Not_found -> accu
+    in
+    Int.Map.fold fold s2 s1
 
   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
+    if is_smaller s1 s2 then fast_diff_l s1 s2
+    else if is_smaller s2 s2 then fast_diff_r s1 s2
+    else
+      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
 
@@ -286,6 +343,8 @@ struct
     let m = Int.Map.find h s in
     Map.find k m
 
+  let get k s = try find k s with Not_found -> assert false
+
   let split k s = assert false (** Cannot be implemented efficiently *)
 
   let map f s =
@@ -322,6 +381,8 @@ struct
     let fs m = Map.smartmapi f m in
     Int.Map.smartmap fs s
 
+  let height s = Int.Map.height s
+
   module Unsafe =
   struct
     let map f s =
@@ -329,4 +390,17 @@ struct
       Int.Map.map fs s
   end
 
+  module Monad(M : CMap.MonadS) =
+  struct
+    module IntM = Int.Map.Monad(M)
+    module ExtM = Map.Monad(M)
+
+    let fold f s accu =
+      let ff _ m accu = ExtM.fold f m accu in
+      IntM.fold ff s accu
+
+    let fold_left _ _ _ = assert false
+    let fold_right _ _ _ = assert false
+  end
+
 end
diff --git a/lib/hashcons.ml b/lib/hashcons.ml
index 144d9513..4eaacf91 100644
--- a/lib/hashcons.ml
+++ b/lib/hashcons.ml
@@ -15,7 +15,7 @@
  *   of objects of type t (u usually has the form (t1->t1)*(t2->t2)*...).
  * [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
+ * [eq] is a comparison function. It is allowed to use physical equality
  *   on the sub-terms hash-consed by the hashcons function.
  * [hash] is the hash function given to the Hashtbl.Make function
  *
@@ -27,7 +27,7 @@ module type HashconsedType =
     type t
     type u
     val hashcons :  u -> t -> t
-    val equal : t -> t -> bool
+    val eq : t -> t -> bool
     val hash : t -> int
   end
 
@@ -53,7 +53,7 @@ module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u) =
 
     (* We create the type of hashtables for t, with our comparison fun.
      * An invariant is that the table never contains two entries equals
-     * w.r.t (=), although the equality on keys is X.equal. This is
+     * w.r.t (=), although the equality on keys is X.eq. This is
      * granted since we hcons the subterms before looking up in the table.
      *)
     module Htbl = Hashset.Make(X)
@@ -72,7 +72,7 @@ module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u) =
 
   end
 
-(* A few usefull wrappers:
+(* A few useful wrappers:
  * 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. *)
@@ -96,20 +96,6 @@ let recursive_hcons h f u =
   let () = loop := hrec in
   hrec
 
-(* A set of global hashcons functions *)
-let hashcons_resets = ref []
-let init() = List.iter (fun f -> f()) !hashcons_resets
-
-(* [register_hcons h u] registers the hcons function h, result of the above
- *   wrappers. It returns another hcons function that always uses the same
- *   table, which can be reinitialized by init()
- *)
-let register_hcons h u =
-  let hf = ref (h u) in
-  let reset() = hf := h u in
-  hashcons_resets := reset :: !hashcons_resets;
-  (fun x -> !hf x)
-
 (* Basic hashcons modules for string and obj. Integers do not need be
    hashconsed.  *)
 
@@ -124,7 +110,7 @@ module Hlist (D:HashedType) =
       let hashcons (hrec,hdata) = function
         | x :: l -> hdata x :: hrec l
         | l -> l
-      let equal l1 l2 =
+      let eq l1 l2 =
         l1 == l2 ||
           match l1, l2 with
           | [], [] -> true
@@ -144,7 +130,7 @@ module Hstring = Make(
     type t = string
     type u = unit
     let hashcons () s =(* incr accesstr;*) s
-    external equal : string -> string -> bool = "caml_string_equal" "noalloc"
+    external eq : string -> string -> bool = "caml_string_equal" "noalloc"
     (** Copy from CString *)
     let rec hash len s i accu =
       if i = len then accu
@@ -191,21 +177,6 @@ module Hobj = Make(
     type t = Obj.t
     type u = (Obj.t -> Obj.t) * unit
     let hashcons (hrec,_) = hash_obj hrec
-    let equal = comp_obj
+    let eq = comp_obj
     let hash = Hashtbl.hash
   end)
-
-(* Hashconsing functions for string and obj. Always use the same
- * global tables. The latter can be reinitialized with init()
- *)
-(* string : string -> string *)
-(* obj : Obj.t -> Obj.t *)
-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) =
-  init();
-  let r = obj (Obj.repr c) in
-  init();
-  (Obj.magic r : 'a)
diff --git a/lib/hashcons.mli b/lib/hashcons.mli
index 04754ba1..150899ce 100644
--- a/lib/hashcons.mli
+++ b/lib/hashcons.mli
@@ -14,9 +14,9 @@ module type HashconsedType =
   sig
     (** {6 Generic hashconsing signature}
 
-        Given an equivalence relation [equal], a hashconsing function is a
+        Given an equivalence relation [eq], 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.
+        related by [eq]. Usually, the element chosen is canonical w.r.t.
         physical equality [(==)], so as to reduce memory consumption and
         enhance efficiency of equality tests.
 
@@ -32,15 +32,15 @@ module type HashconsedType =
         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
+        hashcons substructures. It should be compatible with [eq], that is
+        [eq x (hashcons f x) = true]. *)
+    val eq : 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
+        should be compatible with [eq], i.e. if [eq x y = true] then
         [hash x = hash y]. *)
   end
 
diff --git a/lib/hashset.ml b/lib/hashset.ml
index 6fb78f9a..af33544d 100644
--- a/lib/hashset.ml
+++ b/lib/hashset.ml
@@ -16,7 +16,7 @@
 
 module type EqType = sig
   type t
-  val equal : t -> t -> bool
+  val eq : t -> t -> bool
 end
 
 type statistics = {
@@ -162,7 +162,7 @@ module Make (E : EqType) =
         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;
+          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
@@ -183,7 +183,7 @@ module Make (E : EqType) =
       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
+        | Some v when E.eq v d -> v
         | _ -> loop (i + 1)
       end else loop (i + 1)
     in
diff --git a/lib/hashset.mli b/lib/hashset.mli
index 05d4fe37..733c8962 100644
--- a/lib/hashset.mli
+++ b/lib/hashset.mli
@@ -16,7 +16,7 @@
 
 module type EqType = sig
   type t
-  val equal : t -> t -> bool
+  val eq : t -> t -> bool
 end
 
 type statistics = {
diff --git a/lib/heap.ml b/lib/heap.ml
index 187189fc..97ccadeb 100644
--- a/lib/heap.ml
+++ b/lib/heap.ml
@@ -62,8 +62,6 @@ module Functional(X : Ordered) = struct
 
   let empty = Leaf
 
-  let is_empty t = t = Leaf
-
   let rec add x = function
     | Leaf ->
         Node (Leaf, x, Leaf)
diff --git a/lib/iStream.ml b/lib/iStream.ml
index c9f4d4a1..26a666e1 100644
--- a/lib/iStream.ml
+++ b/lib/iStream.ml
@@ -14,11 +14,11 @@ type 'a node = ('a,'a t) u
 
 and 'a t = 'a node Lazy.t
 
-let empty = Lazy.lazy_from_val Nil
+let empty = Lazy.from_val Nil
 
-let cons x s = Lazy.lazy_from_val (Cons (x, s))
+let cons x s = Lazy.from_val (Cons (x, s))
 
-let thunk = Lazy.lazy_from_fun
+let thunk = Lazy.from_fun
 
 let rec make_node f s = match f s with
 | Nil -> Nil
diff --git a/lib/lib.mllib b/lib/lib.mllib
index f3f6ad8f..8791f074 100644
--- a/lib/lib.mllib
+++ b/lib/lib.mllib
@@ -1,9 +1,10 @@
-Errors
+CErrors
+CWarnings
 Bigint
-Dyn
 Segmenttree
 Unicodetable
 Unicode
+Minisys
 System
 CThread
 Spawn
@@ -15,6 +16,6 @@ Rtree
 Heap
 Unionfind
 Genarg
-Ephemeron
+CEphemeron
 Future
 RemoteCounter
diff --git a/lib/loc.ml b/lib/loc.ml
index afdab928..0f9864a9 100644
--- a/lib/loc.ml
+++ b/lib/loc.ml
@@ -8,7 +8,6 @@
 
 (* Locations management *)
 
-
 type t = {
   fname : string; (** filename *)
   line_nb : int; (** start line number *)
@@ -19,7 +18,7 @@ type t = {
   ep : int; (** end position *)
 }
 
-let create fname line_nb bol_pos (bp, ep) = {
+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; }
 
@@ -54,8 +53,6 @@ let merge loc1 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
 
diff --git a/lib/loc.mli b/lib/loc.mli
index f39cd267..c08e097a 100644
--- a/lib/loc.mli
+++ b/lib/loc.mli
@@ -8,7 +8,15 @@
 
 (** {5 Basic types} *)
 
-type t
+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 *)
+}
 
 type 'a located = t * 'a
 (** Embed a location in a type *)
@@ -17,9 +25,9 @@ type 'a located = t * 'a
 
 (** This is inherited from CAMPL4/5. *)
 
-val create : string -> int -> int -> (int * int) -> t
+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 *)
+    beginning of the line, a start and end position *)
 
 val unloc : t -> int * int
 (** Return the start and end position of a location *)
@@ -35,9 +43,6 @@ val is_ghost : t -> bool
 
 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
diff --git a/lib/minisys.ml b/lib/minisys.ml
new file mode 100644
index 00000000..f15021c6
--- /dev/null
+++ b/lib/minisys.ml
@@ -0,0 +1,66 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Minisys regroups some code that used to be in System.
+    Unlike System, this module has no dependency and could
+    be used for initial compilation target such as coqdep_boot.
+    The functions here are still available in System thanks to
+    an include. For the signature, look at the top of system.mli
+*)
+
+(** Dealing with directories *)
+
+type unix_path = string (* path in unix-style, with '/' separator *)
+
+type file_kind =
+  | FileDir of unix_path * (* basename of path: *) string
+  | FileRegular of string (* basename of file *)
+
+(* Copy of Filename.concat but assuming paths to always be POSIX *)
+
+let (//) dirname filename =
+  let l = String.length dirname in
+  if l = 0 || dirname.[l-1] = '/'
+  then dirname ^ filename
+  else dirname ^ "/" ^ filename
+
+(* Excluding directories; We avoid directories starting with . as well
+   as CVS and _darcs and any subdirs given via -exclude-dir *)
+
+let skipped_dirnames = ref ["CVS"; "_darcs"]
+
+let exclude_directory f = skipped_dirnames := f :: !skipped_dirnames
+
+let ok_dirname f =
+  not (f = "") && f.[0] != '.' &&
+  not (List.mem f !skipped_dirnames) (*&&
+  (match Unicode.ident_refutation f with None -> true | _ -> false)*)
+
+(* Check directory can be opened *)
+
+let exists_dir dir =
+  try Sys.is_directory dir with Sys_error _ -> false
+
+let apply_subdir f path name =
+  (* we avoid all files and subdirs starting by '.' (e.g. .svn) *)
+  (* as well as skipped files like CVS, ... *)
+  if ok_dirname name then
+    let path = if path = "." then name else path//name in
+    match try (Unix.stat path).Unix.st_kind with Unix.Unix_error _ -> Unix.S_BLK with
+    | Unix.S_DIR -> f (FileDir (path,name))
+    | Unix.S_REG -> f (FileRegular name)
+    | _ -> ()
+
+let readdir dir = try Sys.readdir dir with any -> [||]
+
+let process_directory f path =
+  Array.iter (apply_subdir f path) (readdir path)
+
+let process_subdirectories f path =
+  let f = function FileDir (path,base) -> f path base | FileRegular _ -> () in
+  process_directory f path
diff --git a/lib/monad.ml b/lib/monad.ml
index a1714a41..2e55e969 100644
--- a/lib/monad.ml
+++ b/lib/monad.ml
@@ -64,6 +64,9 @@ module type ListS = sig
       its second argument in a tail position. *)
   val iter : ('a -> unit t) -> 'a list -> unit t
 
+  (** Like the regular {!CList.map_filter}. The monadic effects are threaded left*)
+  val map_filter : ('a -> 'b option t) -> 'a list -> 'b list t
+
 
   (** {6 Two-list iterators} *)
 
@@ -138,6 +141,14 @@ module Make (M:Def) : S with type +'a t = 'a M.t = struct
       | a::b::l -> f a >> f b >> iter f l
 
 
+    let rec map_filter f = function
+      | [] -> return []
+      | a::l ->
+        f a >>= function
+        | None -> map_filter f l
+        | Some b ->
+          map_filter f l >>= fun filtered ->
+          return (b::filtered)
 
     let rec fold_left2 r f x l1 l2 =
       match l1,l2 with
diff --git a/lib/monad.mli b/lib/monad.mli
index c8655efa..f7de71f5 100644
--- a/lib/monad.mli
+++ b/lib/monad.mli
@@ -66,6 +66,9 @@ module type ListS = sig
       its second argument in a tail position. *)
   val iter : ('a -> unit t) -> 'a list -> unit t
 
+  (** Like the regular {!CList.map_filter}. The monadic effects are threaded left*)
+  val map_filter : ('a -> 'b option t) -> 'a list -> 'b list t
+
 
   (** {6 Two-list iterators} *)
 
diff --git a/lib/option.ml b/lib/option.ml
index 4ea613e4..fbb883d3 100644
--- a/lib/option.ml
+++ b/lib/option.ml
@@ -41,8 +41,8 @@ let hash f = function
 
 exception IsNone
 
-(** [get x] returns [y] where [x] is [Some y]. It raises IsNone
-    if [x] equals [None]. *)
+(** [get x] returns [y] where [x] is [Some y].
+    @raise [IsNone] if [x] equals [None]. *)
 let get = function
   | Some y -> y
   | _ -> raise IsNone
diff --git a/lib/option.mli b/lib/option.mli
index 409dff9d..5e085620 100644
--- a/lib/option.mli
+++ b/lib/option.mli
@@ -34,8 +34,8 @@ 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]. *)
+(** [get x] returns [y] where [x] is [Some y].
+    @raise IsNone if [x] equals [None]. *)
 val get : 'a option -> 'a
 
 (** [make x] returns [Some x]. *)
@@ -54,7 +54,7 @@ val flatten : 'a option option -> 'a option
 val append : 'a option -> 'a option -> 'a option
 
 
-(** {6 "Iterators"} ***)
+(** {6 "Iterators"} *)
 
 (** [iter f x] executes [f y] if [x] equals [Some y]. It does nothing
     otherwise. *)
@@ -63,8 +63,8 @@ val iter : ('a -> unit) -> 'a option -> unit
 exception Heterogeneous
 
 (** [iter2 f x y] executes [f z w] if [x] equals [Some z] and [y] equals
-    [Some w]. It does nothing if both [x] and [y] are [None]. And raises
-    [Heterogeneous] otherwise. *)
+    [Some w]. It does nothing if both [x] and [y] are [None].
+    @raise Heterogeneous otherwise. *)
 val iter2 : ('a -> 'b -> unit) -> 'a option -> 'b option -> unit
 
 (** [map f x] is [None] if [x] is [None] and [Some (f y)] if [x] is [Some y]. *)
@@ -78,8 +78,8 @@ val smartmap : ('a -> 'a) -> 'a option -> 'a option
 val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a option -> 'b
 
 (** [fold_left2 f a x y] is [f z w] if [x] is [Some z] and [y] is [Some w].
-    It is [a] if both [x] and [y] are [None]. Otherwise it raises
-    [Heterogeneous]. *)
+    It is [a] if both [x] and [y] are [None].
+    @raise Heterogeneous otherwise. *)
 val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b option -> 'c option -> 'a
 
 (** [fold_right f x a] is [f y a] if [x] is [Some y], and [a] otherwise. *)
@@ -91,7 +91,7 @@ val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b option -> 'a * 'c option
 (** [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} ***)
+(** {6 More Specific Operations} *)
 
 (** [default a x] is [y] if [x] is [Some y] and [a] otherwise. *)
 val default : 'a -> 'a option -> 'a
diff --git a/lib/pp.ml b/lib/pp.ml
index 4f50e3e1..f3bb4753 100644
--- a/lib/pp.ml
+++ b/lib/pp.ml
@@ -51,37 +51,19 @@ sig
   val prj : t -> 'a key -> 'a option
 end =
 struct
-  (** See module {Dyn} for more details. *)
 
-  type t = int * Obj.t
+module Dyn = Dyn.Make(struct end)
 
-  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
+type t = Dyn.t
+type 'a key = 'a Dyn.tag
+let create = Dyn.create
+let inj = Dyn.Easy.inj
+let prj = Dyn.Easy.prj
 
 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;
@@ -95,17 +77,6 @@ let print_emacs = ref false
    \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
@@ -129,7 +100,7 @@ type 'a ppcmd_token =
   | Ppcmd_open_box of block_type
   | Ppcmd_close_box
   | Ppcmd_close_tbox
-  | Ppcmd_comment of int
+  | Ppcmd_comment of string list
   | Ppcmd_open_tag of Tag.t
   | Ppcmd_close_tag
 
@@ -195,7 +166,7 @@ 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)
+let comment l = Glue.atom(Ppcmd_comment l)
 
 (* derived commands *)
 let mt () = Glue.empty
@@ -215,6 +186,25 @@ let strbrk s =
     else if p = n then [] else [str (String.sub s p (n-p))]
   in List.fold_left (++) Glue.empty (aux 0 0)
 
+let pr_loc_pos loc =
+  if Loc.is_ghost loc then (str"<unknown>")
+  else
+    let loc = Loc.unloc loc in
+    int (fst loc) ++ str"-" ++ int (snd loc)
+
+let pr_loc loc =
+  if Loc.is_ghost loc then str"<unknown>" ++ fnl ()
+  else
+    let fname = loc.Loc.fname in
+    if CString.equal fname "" then
+      Loc.(str"Toplevel input, characters " ++ int loc.bp ++
+	   str"-" ++ int loc.ep ++ str":" ++ fnl ())
+    else
+      Loc.(str"File " ++ str "\"" ++ str fname ++ str "\"" ++
+	   str", line " ++ int loc.line_nb ++ str", characters " ++
+	   int (loc.bp-loc.bol_pos) ++ str"-" ++ int (loc.ep-loc.bol_pos) ++
+	   str":" ++ fnl())
+
 let ismt = is_empty
 
 (* boxing commands *)
@@ -253,32 +243,15 @@ let qstring s = str "\"" ++ str (escape_string s) ++ str "\""
 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)
+      Some s2 -> Format.pp_force_newline ft (); pr_com ft s2
     | None -> ()
 
 type tag_handler = Tag.t -> Format.tag
@@ -297,34 +270,24 @@ let pp_dirs ?pp_tag ft =
         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
+          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
+          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_open_box bty      -> 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_white_space n     -> Format.pp_print_break ft n 0
+    | Ppcmd_print_break(m,n)  -> 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_print_tbreak(m,n) -> Format.pp_print_tbreak ft m n
+    | Ppcmd_force_newline     -> Format.pp_force_newline ft ()
+    | Ppcmd_print_if_broken   -> Format.pp_print_if_newline ft ()
+    | Ppcmd_comment coms      -> List.iter (pr_com ft) coms
     | Ppcmd_open_tag tag ->
       begin match pp_tag with
       | None -> ()
@@ -338,193 +301,41 @@ let pp_dirs ?pp_tag ft =
   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_newline    -> 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
+      Glue.iter pp_dir dirstream
     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 hov 0 (str emacs_quote_start ++ g ++ str emacs_quote_end)
-  else hov 0 g
-
-let emacs_quote_info g =
-  if !print_emacs then hov 0 (str emacs_quote_info_start++ brk(0,0) ++ g ++ brk(0,0) ++ 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 ())))
-
-(* 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 = emacs_quote_info (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 ft_logger old_logger ft ~id level mesg = match level with
-  | Debug _ -> msgnl_with ft (debugbody mesg)
-  | Info -> msgnl_with ft (infobody mesg)
-  | Notice -> msgnl_with ft mesg
-  | Warning -> old_logger ~id:id level mesg
-  | Error -> old_logger ~id:id level mesg
-
-let with_output_to_file fname func input =
-  let old_logger = !logger in
-  let channel = open_out (String.concat "." [fname; "out"]) in
-  logger := ft_logger old_logger (Format.formatter_of_out_channel channel);
-  try
-    let output = func input in
-    logger := old_logger;
-    close_out channel;
-    output
-  with reraise ->
-    let reraise = Backtrace.add_backtrace reraise in
-    logger := old_logger;
-    close_out channel;
-    Exninfo.iraise reraise
-
-let feedback_id = ref (Feedback.Edit 0)
-let feedback_route = ref Feedback.default_route
+let msg_with ?pp_tag ft strm =
+  pp_dirs ?pp_tag ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_flush))
 
 (* 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 *)
-
+(** Output to a string formatter *)
 let string_of_ppcmds c =
-  msg_with Format.str_formatter c;
+  Format.fprintf Format.str_formatter "@[%a@]" (msg_with ?pp_tag:None) 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_non_empty_arg pr x = let pp = pr x in if ismt pp then mt () else 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
 
@@ -607,3 +418,4 @@ let prvect_with_sep sep elem v = prvecti_with_sep sep (fun _ -> elem) v
 let prvect elem v = prvect_with_sep mt elem v
 
 let surround p = hov 1 (str"(" ++ p ++ str")")
+
diff --git a/lib/pp.mli b/lib/pp.mli
index 2508779e..8342a983 100644
--- a/lib/pp.mli
+++ b/lib/pp.mli
@@ -6,33 +6,24 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(** 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. *)
-val make_pp_emacs:unit -> unit
-val make_pp_nonemacs:unit -> unit
-
-val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b
-
 (** Pretty-printers. *)
 
 type std_ppcmds
 
 (** {6 Formatting commands} *)
 
-val str  : string -> std_ppcmds
+val str   : string -> std_ppcmds
 val stras : int * string -> std_ppcmds
-val brk : int * int -> std_ppcmds
-val tbrk : int * int -> std_ppcmds
-val tab : unit -> std_ppcmds
-val fnl : unit -> std_ppcmds
-val pifb : unit -> std_ppcmds
-val ws : int -> std_ppcmds
-val mt : unit -> std_ppcmds
-val ismt : std_ppcmds -> bool
-
-val comment : int -> std_ppcmds
-val comments : ((int * int) * string) list ref
+val brk   : int * int -> std_ppcmds
+val tbrk  : int * int -> std_ppcmds
+val tab   : unit -> std_ppcmds
+val fnl   : unit -> std_ppcmds
+val pifb  : unit -> std_ppcmds
+val ws    : int -> std_ppcmds
+val mt    : unit -> std_ppcmds
+val ismt  : std_ppcmds -> bool
+
+val comment  : string list -> std_ppcmds
 
 (** {6 Manipulation commands} *)
 
@@ -100,87 +91,10 @@ sig
   (** 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
@@ -199,6 +113,9 @@ val pr_bar : unit -> std_ppcmds
 val pr_arg : ('a -> std_ppcmds) -> 'a -> std_ppcmds
 (** Adds a space in front of its argument. *)
 
+val pr_non_empty_arg : ('a -> std_ppcmds) -> 'a -> std_ppcmds
+(** Adds a space in front of its argument if non empty. *)
+
 val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
 (** Inner object preceded with a space if [Some], nothing otherwise. *)
 
@@ -248,31 +165,15 @@ val surround : std_ppcmds -> std_ppcmds
 
 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]. } *)
+val pr_loc : Loc.t -> std_ppcmds
 
-(** These functions are low-level interface to printing and should not be used
-    in usual code. Consider using the [msg_*] function family instead. *)
+(** {6 Low-level pretty-printing functions with and without flush} *)
 
-val pp : std_ppcmds -> unit
-val ppnl : std_ppcmds -> unit
-val pperr : std_ppcmds -> unit
-val pperrnl : std_ppcmds -> unit
-val pperr_flush : unit -> unit
-val pp_flush : unit -> unit
-val flush_all: unit -> unit
-
-(** {6 Deprecated functions} *)
-
-(** DEPRECATED. Do not use in newly written code. *)
+(** FIXME: These ignore the logging settings and call [Format] directly *)
+type tag_handler = Tag.t -> Format.tag
 
-val msg_with : Format.formatter -> std_ppcmds -> unit
+(** [msg_with ?pp_tag fmt pp] Print [pp] to [fmt] and flush [fmt]  *)
+val msg_with : ?pp_tag:tag_handler -> 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 message : string -> unit       (** = pPNL *)
+(** [msg_with ?pp_tag fmt pp] Print [pp] to [fmt] and don't flush [fmt]  *)
+val pp_with  : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit
diff --git a/lib/ppstyle.ml b/lib/ppstyle.ml
index bb73fbdf..aa47c516 100644
--- a/lib/ppstyle.ml
+++ b/lib/ppstyle.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Util
+module String = CString
 
 type t = string
 (** We use the concatenated string, with dots separating each string. We
@@ -56,41 +56,6 @@ let default = Terminal.({
 
 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"]
@@ -106,44 +71,3 @@ let debug_tag =
 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/lib/ppstyle.mli b/lib/ppstyle.mli
index 97b5869f..d9fd7576 100644
--- a/lib/ppstyle.mli
+++ b/lib/ppstyle.mli
@@ -11,7 +11,8 @@
 
 (** {5 Style tags} *)
 
-type t
+type t = string
+
 (** Style tags *)
 
 val make : ?style:Terminal.style -> string list -> t
@@ -43,15 +44,7 @@ val parse_config : string -> unit
 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! *)
+(** {5 Color output} *)
 
 val pp_tag : Pp.tag_handler
 (** Returns the name of a style tag that is understandable by the formatters
diff --git a/lib/profile.ml b/lib/profile.ml
index 2350cd43..d620fe69 100644
--- a/lib/profile.ml
+++ b/lib/profile.ml
@@ -146,9 +146,9 @@ let merge_profile filename (curr_table, curr_outside, curr_total as new_data) =
    number of allocated bytes may exceed the maximum integer capacity
    (2^31 on 32-bits architectures);  therefore, allocation is measured
    by small steps, total allocations are computed by adding elementary
-   measures and carries are controled from step to step *)
+   measures and carries are controlled from step to step *)
 
-(* Unix measure of time is approximative and shoitt delays are often
+(* Unix measure of time is approximate and short delays are often
    unperceivable; therefore, total times are measured in one (big)
    step to avoid rounding errors and to get the best possible
    approximation.
@@ -260,7 +260,7 @@ let time_overhead_B_C () =
       let _dw = dummy_spent_alloc () in
       let _dt = get_time () in
       ()
-    with e when Errors.noncritical e -> assert false
+    with e when CErrors.noncritical e -> assert false
   done;
   let after = get_time () in
   let beforeloop =  get_time () in
@@ -358,7 +358,7 @@ let declare_profile name =
   prof_table := (name,e)::!prof_table;
   e
 
-(* Default initialisation, may be overriden *)
+(* Default initialization, may be overridden *)
 let _ = init_profile ()
 
 (******************************)
diff --git a/lib/remoteCounter.ml b/lib/remoteCounter.ml
index 3f198259..e7646fb7 100644
--- a/lib/remoteCounter.ml
+++ b/lib/remoteCounter.ml
@@ -20,19 +20,21 @@ let new_counter ~name a ~incr ~build =
   let data = ref (ref a) in
   counters := (name, Obj.repr data) :: !counters;
   let m = Mutex.create () in
-  let mk_thsafe_getter f () =
+  let mk_thsafe_local_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");
+      CErrors.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 mk_thsafe_remote_getter f () =
+    Mutex.lock m; let x = f () in Mutex.unlock m; x in
+  let getter = ref(mk_thsafe_local_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
+      CErrors.anomaly(Pp.str"Only slave processes can install a remote counter");
+    getter := mk_thsafe_remote_getter f in
   (fun () -> !getter ()), installer
 
 let backup () = !counters
diff --git a/lib/richpp.ml b/lib/richpp.ml
index 453df43d..a98273ed 100644
--- a/lib/richpp.ml
+++ b/lib/richpp.ml
@@ -163,4 +163,34 @@ let xml_of_rich_pp tag_of_annotation attributes_of_annotation xml =
   in
   node xml
 
+type richpp = xml
+
+let repr xml = xml
+let richpp_of_xml xml = xml
+let richpp_of_string s = PCData s
+
+let richpp_of_pp pp =
+  let annotate t = match Pp.Tag.prj t Ppstyle.tag with
+  | None -> None
+  | Some key -> Some (Ppstyle.repr key)
+  in
+  let rec drop = function
+  | PCData s -> [PCData s]
+  | Element (_, annotation, cs) ->
+    let cs = List.concat (List.map drop cs) in
+    match annotation.annotation with
+    | None -> cs
+    | Some s -> [Element (String.concat "." s, [], cs)]
+  in
+  let xml = rich_pp annotate pp in
+  Element ("_", [], drop xml)
+
+let raw_print xml =
+  let buf = Buffer.create 1024 in
+  let rec print = function
+  | PCData s -> Buffer.add_string buf s
+  | Element (_, _, cs) -> List.iter print cs
+  in
+  let () = print xml in
+  Buffer.contents buf
 
diff --git a/lib/richpp.mli b/lib/richpp.mli
index 05c16621..287d265a 100644
--- a/lib/richpp.mli
+++ b/lib/richpp.mli
@@ -39,3 +39,26 @@ val xml_of_rich_pp :
   ('annotation -> (string * string) list) ->
   'annotation located Xml_datatype.gxml ->
   Xml_datatype.xml
+
+(** {5 Enriched text} *)
+
+type richpp
+(** Type of text with style annotations *)
+
+val richpp_of_pp : Pp.std_ppcmds -> richpp
+(** Extract style information from formatted text *)
+
+val richpp_of_xml : Xml_datatype.xml -> richpp
+(** Do not use outside of dedicated areas *)
+
+val richpp_of_string : string -> richpp
+(** Make a styled text out of a normal string *)
+
+val repr : richpp -> Xml_datatype.xml
+(** Observe the styled text as XML *)
+
+(** {5 Debug/Compat} *)
+
+(** Represent the semi-structured document as a string, dropping any additional
+    information. *)
+val raw_print : richpp -> string
diff --git a/lib/spawn.ml b/lib/spawn.ml
index 4d35ded9..47917697 100644
--- a/lib/spawn.ml
+++ b/lib/spawn.ml
@@ -43,7 +43,7 @@ module type MainLoopModel = sig
 end
 
 (* Common code *)
-let assert_ b s = if not b then Errors.anomaly (Pp.str s)
+let assert_ b s = if not b then CErrors.anomaly (Pp.str s)
 
 (* According to http://caml.inria.fr/mantis/view.php?id=5325
  * you can't use the same socket for both writing and reading (may change
@@ -78,20 +78,6 @@ let accept (sr,sw) =
   set_binary_mode_out cout true;
   (csr, csw), 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
@@ -206,7 +192,7 @@ let spawn ?(prefer_sock=prefer_sock) ?(env=Unix.environment ())
         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 ->
+      with e when CErrors.noncritical e ->
         pr_err ("Async reader raised: " ^ (Printexc.to_string e));
         kill p;
         false) gchan
@@ -220,10 +206,13 @@ let stats { oob_req; oob_resp; alive } =
   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
+  (* On windows kill is not reliable, so wait may never return. *) 
+  if Sys.os_type = "Unix" then 
+    try snd (Unix.waitpid [] p.pid)
+    with
+    | Unix.Unix_error (Unix.EINTR, _, _) -> wait p
+    | Unix.Unix_error _ -> Unix.WEXITED 0o400
+  else Unix.WEXITED 0o400
 
 end
 
@@ -267,8 +256,13 @@ let stats { oob_req; oob_resp; alive } =
   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
+let rec wait p =
+  (* On windows kill is not reliable, so wait may never return. *) 
+  if Sys.os_type = "Unix" then 
+    try snd (Unix.waitpid [] p.pid)
+    with
+    | Unix.Unix_error (Unix.EINTR, _, _) -> wait p
+    | Unix.Unix_error _ -> Unix.WEXITED 0o400
+  else Unix.WEXITED 0o400
 
 end
diff --git a/lib/stateid.ml b/lib/stateid.ml
index 59cf206e..ae25735c 100644
--- a/lib/stateid.ml
+++ b/lib/stateid.ml
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Xml_datatype
-
 type t = int
 let initial = 1
 let dummy = 0
@@ -15,29 +13,29 @@ 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 of_int id =
+  (* 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
 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 =
+let add exn ~valid 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)
+module Self = struct
+ type t = int
+ let compare = compare
+ let equal = equal
+end
+
+module Set = Set.Make(Self)
 
 type ('a,'b) request = {
   exn_info : t * t;
diff --git a/lib/stateid.mli b/lib/stateid.mli
index 2c12c30c..1d87a343 100644
--- a/lib/stateid.mli
+++ b/lib/stateid.mli
@@ -6,32 +6,28 @@
 (*         *       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
+module Self : Map.OrderedType with type t = t
+module Set : Set.S with type elt = t and type t = Set.Make(Self).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
+val newer_than : t -> t -> bool
 
 (* 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
+ * Backtracking to the valid id is safe. *)
+val add : Exninfo.info -> valid:t -> t -> Exninfo.info
 val get : Exninfo.info -> (t * t) option
 
 type ('a,'b) request = {
diff --git a/lib/system.ml b/lib/system.ml
index 9bdcecef..4b99de70 100644
--- a/lib/system.ml
+++ b/lib/system.ml
@@ -9,38 +9,32 @@
 (* $Id$ *)
 
 open Pp
-open Errors
 open Util
 
-(* All subdirectories, recursively *)
+include Minisys
 
-let exists_dir dir =
-  try Sys.is_directory dir with Sys_error _ -> false
+(** Returns the list of all recursive subdirectories of [root] in
+    depth-first search, with sons ordered as on the file system;
+    warns if [root] does not exist *)
 
-let skipped_dirnames = ref ["CVS"; "_darcs"]
-
-let exclude_search_in_dirname f = skipped_dirnames := f :: !skipped_dirnames
-
-let ok_dirname f =
-  not (String.is_empty f) && f.[0] != '.' &&
-  not (String.List.mem f !skipped_dirnames) &&
-  (match Unicode.ident_refutation f with None -> true | _ -> false)
+let warn_cannot_open_dir =
+  CWarnings.create ~name:"cannot-open-dir" ~category:"filesystem"
+  (fun dir -> str ("Cannot open directory " ^ dir))
 
 let all_subdirs ~unix_path:root =
   let l = ref [] in
   let add f rel = l := (f, rel) :: !l in
-  let rec traverse dir rel =
-    Array.iter (fun f ->
-      if ok_dirname f then
-	let file = Filename.concat dir f in
-        if Sys.is_directory file then begin
-          let newrel = rel @ [f] in
-	  add file newrel;
-	  traverse file newrel
-        end)
-      (Sys.readdir dir)
+  let rec traverse path rel =
+    let f = function
+      | FileDir (path,f) ->
+	  let newrel = rel @ [f] in
+	  add path newrel;
+	  traverse path newrel
+      | _ -> ()
+    in process_directory f path
   in
-  if exists_dir root then traverse root [];
+  if exists_dir root then traverse root []
+  else warn_cannot_open_dir root;
   List.rev !l
 
 (* Caching directory contents for efficient syntactic equality of file
@@ -58,23 +52,25 @@ let dirmap = ref StrMap.empty
 
 let make_dir_table dir =
   let filter_dotfiles s f = if f.[0] = '.' then s else StrSet.add f s in
-  Array.fold_left filter_dotfiles StrSet.empty (Sys.readdir dir)
+  Array.fold_left filter_dotfiles StrSet.empty (readdir dir)
 
 let exists_in_dir_respecting_case dir bf =
-  let contents, cached =
-    try StrMap.find dir !dirmap, true with Not_found ->
+  let cache_dir dir =
     let contents = make_dir_table dir in
     dirmap := StrMap.add dir contents !dirmap;
-    contents, false in
+    contents in
+  let contents, fresh =
+    try
+      (* in batch mode, assume the directory content is still fresh *)
+      StrMap.find dir !dirmap, !Flags.batch_mode
+    with Not_found ->
+      (* in batch mode, we are not yet sure the directory exists *)
+      if !Flags.batch_mode && not (exists_dir dir) then StrSet.empty, true
+      else cache_dir dir, true in
   StrSet.mem bf contents ||
-    if cached then begin
+    not fresh &&
       (* rescan, there is a new file we don't know about *)
-      let contents = make_dir_table dir in
-      dirmap := StrMap.add dir contents !dirmap;
-      StrSet.mem bf contents
-    end
-    else
-      false
+      StrSet.mem bf (cache_dir dir)
 
 let file_exists_respecting_case path f =
   (* This function ensures that a file with expected lowercase/uppercase
@@ -84,26 +80,29 @@ let file_exists_respecting_case path f =
     let df = Filename.dirname f in
     (String.equal df "." || aux df)
     && exists_in_dir_respecting_case (Filename.concat path df) bf
-  in Sys.file_exists (Filename.concat path f) && aux f
+  in (!Flags.batch_mode || Sys.file_exists (Filename.concat path f)) && aux f
 
 let rec search paths test =
   match paths with
   | [] -> []
   | lpe :: rem -> test lpe @ search rem test
 
+let warn_ambiguous_file_name =
+  CWarnings.create ~name:"ambiguous-file-name" ~category:"filesystem"
+    (fun (filename,l,f) -> 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)
+
+
 let where_in_path ?(warn=true) path filename =
   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)
+    | _ :: _ when warn -> warn_ambiguous_file_name (filename,l,f)
     | _ -> ()
     in
     (lpe, f)
@@ -132,7 +131,7 @@ let find_file_in_path ?(warn=true) paths filename =
       let root = Filename.dirname filename in
       root, filename
     else
-      errorlabstrm "System.find_file_in_path"
+      CErrors.errorlabstrm "System.find_file_in_path"
 	(hov 0 (str "Can't find file" ++ spc () ++ str filename))
   else
     (* the name is considered to be the transcription as a relative
@@ -140,7 +139,7 @@ let find_file_in_path ?(warn=true) paths filename =
        to be locate respecting case *)
     try where_in_path ~warn paths filename
     with Not_found ->
-      errorlabstrm "System.find_file_in_path"
+      CErrors.errorlabstrm "System.find_file_in_path"
 	(hov 0 (str "Can't find file" ++ spc () ++ str filename ++ spc () ++
 		str "on loadpath"))
 
@@ -148,25 +147,34 @@ let is_in_path lpath filename =
   try ignore (where_in_path ~warn:false lpath filename); true
   with Not_found -> false
 
+let warn_path_not_found =
+  CWarnings.create ~name:"path-not-found" ~category:"filesystem"
+  (fun () -> str "system variable PATH not found")
+
 let is_in_system_path filename =
-  let path = try Sys.getenv "PATH"
-             with Not_found -> error "system variable PATH not found" in
-  let lpath = CUnix.path_to_list path in
-  is_in_path lpath filename
+  try
+    let lpath = CUnix.path_to_list (Sys.getenv "PATH") in
+    is_in_path lpath filename
+  with Not_found ->
+    warn_path_not_found ();
+    false
 
 let open_trapping_failure name =
   try open_out_bin name
-  with e when Errors.noncritical e ->
-    errorlabstrm "System.open" (str "Can't open " ++ str name)
+  with e when CErrors.noncritical e ->
+    CErrors.errorlabstrm "System.open" (str "Can't open " ++ str name)
+
+let warn_cannot_remove_file =
+  CWarnings.create ~name:"cannot-remove-file" ~category:"filesystem"
+  (fun filename -> str"Could not remove file " ++ str filename ++ str" which is corrupted!")
 
 let try_remove filename =
   try Sys.remove filename
-  with e when Errors.noncritical e ->
-    msg_warning
-      (str"Could not remove file " ++ str filename ++ str" which is corrupted!")
+  with e when CErrors.noncritical e ->
+    warn_cannot_remove_file filename
 
 let error_corrupted file s =
-  errorlabstrm "System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.")
+  CErrors.errorlabstrm "System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.")
 
 let input_binary_int f ch =
   try input_binary_int ch
@@ -210,7 +218,8 @@ let skip_in_segment f ch =
   seek_in ch stop;
   stop, digest_in f ch
 
-exception Bad_magic_number of string
+type magic_number_error = {filename: string; actual: int; expected: int}
+exception Bad_magic_number of magic_number_error
 
 let raw_extern_state magic filename =
   let channel = open_trapping_failure filename in
@@ -220,8 +229,12 @@ let raw_extern_state magic filename =
 let raw_intern_state magic filename =
   try
     let channel = open_in_bin filename in
-    if not (Int.equal (input_binary_int filename channel) magic) then
-      raise (Bad_magic_number filename);
+    let actual_magic = input_binary_int filename channel in
+    if not (Int.equal actual_magic magic) then
+        raise (Bad_magic_number {
+            filename=filename;
+            actual=actual_magic;
+            expected=magic});
     channel
   with
   | End_of_file -> error_corrupted filename "premature end of file"
@@ -234,11 +247,11 @@ let extern_state magic filename val_0 =
       marshal_out channel val_0;
       close_out channel
     with reraise ->
-      let reraise = Errors.push reraise in
+      let reraise = CErrors.push reraise in
       let () = try_remove filename in
       iraise reraise
   with Sys_error s ->
-    errorlabstrm "System.extern_state" (str "System error: " ++ str s)
+    CErrors.errorlabstrm "System.extern_state" (str "System error: " ++ str s)
 
 let intern_state magic filename =
   try
@@ -247,13 +260,15 @@ let intern_state magic filename =
     close_in channel;
     v
   with Sys_error s ->
-    errorlabstrm "System.intern_state" (str "System error: " ++ str s)
+    CErrors.errorlabstrm "System.intern_state" (str "System error: " ++ str s)
 
 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 () ++
+  with Bad_magic_number {filename=fname;actual=actual;expected=expected} ->
+    CErrors.errorlabstrm "with_magic_number_check"
+    (str"File " ++ str fname ++ strbrk" has bad magic number " ++
+    int actual ++ str" (expected " ++ int expected ++ str")." ++
+    spc () ++
     strbrk "It is corrupted or was compiled with another version of Coq.")
 
 (* Time stamps. *)
@@ -284,13 +299,13 @@ let with_time time f x =
     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);
+    Feedback.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);
+    Feedback.msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2);
     raise e
 
 let process_id () =
diff --git a/lib/system.mli b/lib/system.mli
index 062c8ea8..21436909 100644
--- a/lib/system.mli
+++ b/lib/system.mli
@@ -8,14 +8,41 @@
 
 (** {5 Coqtop specific system utilities} *)
 
+(** {6 Directories} *)
+
+type unix_path = string (* path in unix-style, with '/' separator *)
+
+type file_kind =
+  | FileDir of unix_path * (* basename of path: *) string
+  | FileRegular of string (* basename of file *)
+
+val (//) : unix_path -> string -> unix_path
+
+val exists_dir : unix_path -> bool
+
+(** [exclude_search_in_dirname path] excludes [path] when processing
+    directories *)
+
+val exclude_directory : unix_path -> unit
+
+(** [process_directory f path] applies [f] on contents of directory
+    [path]; fails with Unix_error if the latter does not exists; skips
+    all files or dirs starting with "." *)
+
+val process_directory : (file_kind -> unit) -> unix_path -> unit
+
+(** [process_subdirectories f path] applies [f path/file file] on each
+    [file] of the directory [path]; fails with Unix_error if the
+    latter does not exists; kips all files or dirs starting with "." *)
+
+val process_subdirectories : (unix_path -> string -> unit) -> unix_path -> unit
+
 (** {6 Files and load paths} *)
 
 (** Load path entries remember the original root
     given by the user. For efficiency, we keep the full path (field
     [directory]), the root path and the path relative to the root. *)
 
-val exclude_search_in_dirname : string -> unit
-
 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
@@ -24,8 +51,6 @@ val where_in_path :
 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 -> CUnix.load_path -> string -> CUnix.physical_path * string
 
@@ -34,9 +59,11 @@ val file_exists_respecting_case : string -> string -> bool
 (** {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. *)
+  when the check fails, with the full file name and expected/observed magic
+  numbers. *)
 
-exception Bad_magic_number of string
+type magic_number_error = {filename: string; actual: int; expected: int}
+exception Bad_magic_number of magic_number_error
 
 val raw_extern_state : int -> string -> out_channel
 
diff --git a/lib/unicode.ml b/lib/unicode.ml
index 1765e93d..ced5e258 100644
--- a/lib/unicode.ml
+++ b/lib/unicode.ml
@@ -8,9 +8,7 @@
 
 (** Unicode utilities *)
 
-type status = Letter | IdentPart | Symbol
-
-exception Unsupported
+type status = Letter | IdentPart | Symbol | Unknown
 
 (* The following table stores classes of Unicode characters that
    are used by the lexer. There are 3 different classes so 2 bits are
@@ -18,7 +16,7 @@ exception Unsupported
    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. *)
+(* A 256 KiB table, initially filled with zeros. *)
 let table = Array.make (1 lsl 17) 0
 
 (* Associate a 2-bit pattern to each status at position [i].
@@ -29,6 +27,7 @@ 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 *)
+  | Unknown   -> 0 lsl ((i land 7) lsl 1) (* 00 *)
 
 (* Helper to reset 2 bits in a word. *)
 let reset_mask i =
@@ -55,7 +54,7 @@ let lookup x =
     if      v = 1 then Letter
     else if v = 2 then IdentPart
     else if v = 3 then Symbol
-    else raise Unsupported
+    else Unknown
 
 (* [classify] discriminates between 3 different kinds of
    symbols based on the standard unicode classification (extracted from
@@ -147,6 +146,11 @@ let utf8_of_unicode n =
       s
     end
 
+(* If [s] is some UTF-8 encoded string
+   and [i] is a position of some UTF-8 character within [s]
+   then [next_utf8 s i] returns [(j,n)] where:
+   - [j] indicates the position of the next UTF-8 character
+   - [n] represents the UTF-8 character at index [i] *)
 let next_utf8 s i =
   let err () = invalid_arg "utf8" in
   let l = String.length s - i in
@@ -168,6 +172,13 @@ let next_utf8 s i =
        (c land 0x3F) lsl 6 + (d land 0x3F)
   else err ()
 
+let is_utf8 s =
+  let rec check i =
+    let (off, _) = next_utf8 s i in
+    check (i + off)
+  in
+  try check 0 with End_of_input -> true | Invalid_argument _ -> false
+
 (* Check the well-formedness of an identifier *)
 
 let initial_refutation j n s =
@@ -203,7 +214,6 @@ let ident_refutation s =
         |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 =
@@ -228,14 +238,94 @@ let is_basic_ascii 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 len = String.length s in
+  let has_UU i =
+    i+2 < len && s.[i]='_' && s.[i+1]='U' && s.[i+2]='U'
+  in
+  let i = ref 0 in
+  while !i < len && Char.code s.[!i] < 128 && not (has_UU !i) do
+    incr i
+  done;
+  if !i = len then s else
+    let out = Buffer.create (2*len) in
+    Buffer.add_substring out s 0 !i;
+    while !i < len 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
+      if n >= 128 then
+        (Printf.bprintf out "_UU%04x_" n; i := !i + j)
+      else if has_UU !i then
+        (Buffer.add_string out "_UUU"; i := !i + 3)
+      else
+        (Buffer.add_char out s.[!i]; incr i)
+    done;
+    Buffer.contents out
+
+(* 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 *)
+
+(** FIXME: duplicate code with Pp *)
+
+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
+
+(* Variant of String.sub for UTF8 character positions *)
+let utf8_sub s start_u len_u =
+  let len_b = String.length s
+  and end_u = start_u + len_u
+  and cnt = ref 0
+  and nc = ref 0
+  and p = ref 0 in
+  let start_b = ref len_b in
+  while !p < len_b && !cnt < end_u do
+    if !cnt <= start_u then start_b := !p ;
+    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_b && !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 ;
+  let end_b = !p in
+  String.sub s !start_b (end_b - !start_b)
diff --git a/lib/unicode.mli b/lib/unicode.mli
index 520203d4..2609e196 100644
--- a/lib/unicode.mli
+++ b/lib/unicode.mli
@@ -8,21 +8,35 @@
 
 (** Unicode utilities *)
 
-type status = Letter | IdentPart | Symbol
+type status = Letter | IdentPart | Symbol | Unknown
 
-exception Unsupported
-
-(** Classify a unicode char into 3 classes, or raise [Unsupported] *)
+(** Classify a unicode char into 3 classes or unknown. *)
 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] *)
+(** Return [None] if a given string can be used as a (Coq) identifier.
+    Return [Some (b,s)] otherwise, where [s] is an explanation and [b] is severity. *)
 val ident_refutation : string -> (bool * string) option
 
-(** First char of a string, converted to lowercase *)
+(** First char of a string, converted to lowercase
+    @raise Assert_failure if the input string is empty. *)
 val lowercase_first_char : string -> string
 
-(** For extraction, turn a unicode string into an ascii-only one *)
+(** Return [true] if all UTF-8 characters in the input string are just plain
+    ASCII characters. Returns [false] otherwise. *)
 val is_basic_ascii : string -> bool
+
+(** [ascii_of_ident s] maps UTF-8 string to a string composed solely from ASCII
+    characters. The non-ASCII characters are translated to ["_UUxxxx_"] where
+    {i xxxx} is the Unicode index of the character in hexadecimal (from four
+    to six hex digits). To avoid potential name clashes, any preexisting
+    substring ["_UU"] is turned into ["_UUU"]. *)
 val ascii_of_ident : string -> string
+
+(** Validate an UTF-8 string *)
+val is_utf8 : string -> bool
+
+(** Return the length of a valid UTF-8 string. *)
+val utf8_length : string -> int
+
+(** Variant of {!String.sub} for UTF-8 strings. *)
+val utf8_sub : string -> int -> int -> string
diff --git a/lib/util.ml b/lib/util.ml
index a20dba0f..009dfbe1 100644
--- a/lib/util.ml
+++ b/lib/util.ml
@@ -87,7 +87,13 @@ let matrix_transpose mat =
 
 let identity x = x
 
-let compose f g x = f (g x)
+(** Function composition: the mathematical [∘] operator.
+
+    So [g % f] is a synonym for [fun x -> g (f x)].
+
+    Also because [%] is right-associative, [h % g % f] means [fun x -> h (g (f x))].
+ *)
+let (%) f g x = f (g x)
 
 let const x _ = x
 
@@ -124,10 +130,26 @@ let delayed_force f = f ()
 
 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
+type ('a, 'b) eq = ('a, 'b) CSig.eq = Refl : ('a, 'a) eq
+
+module Union =
+struct
+  let map f g = function
+    | Inl a -> Inl (f a)
+    | Inr b -> Inr (g b)
+
+  (** Lifting equality onto union types. *)
+  let equal f g x y = match x, y with
+    | Inl x, Inl y -> f x y
+    | Inr x, Inr y -> g x y
+    | _, _ -> false
+
+  let fold_left f g a = function
+    | Inl y -> f a y
+    | Inr y -> g a y
+end
 
-let map_union f g = function
-  | Inl a -> Inl (f a)
-  | Inr b -> Inr (g b)
+let map_union = Union.map
 
 type iexn = Exninfo.iexn
 
diff --git a/lib/util.mli b/lib/util.mli
index 4156af67..6bed7e35 100644
--- a/lib/util.mli
+++ b/lib/util.mli
@@ -83,7 +83,15 @@ val matrix_transpose : 'a list list -> 'a list list
 (** {6 Functions. } *)
 
 val identity : 'a -> 'a
-val compose : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b
+
+(** Function composition: the mathematical [∘] operator.
+
+    So [g % f] is a synonym for [fun x -> g (f x)].
+
+    Also because [%] is right-associative, [h % g % f] means [fun x -> h (g (f x))].
+*)
+val (%) : ('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
@@ -106,10 +114,20 @@ val iraise : iexn -> 'a
 type ('a, 'b) union = ('a, 'b) CSig.union = Inl of 'a | Inr of 'b
 (** Union type *)
 
+module Union :
+sig
+  val map : ('a -> 'c) -> ('b -> 'd) -> ('a, 'b) union -> ('c, 'd) union
+  val equal : ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a, 'b) union -> ('a, 'b) union -> bool
+  val fold_left : ('c -> 'a -> 'c) -> ('c -> 'b -> 'c) -> 'c -> ('a, 'b) union -> 'c
+end
+
 val map_union : ('a -> 'c) -> ('b -> 'd) -> ('a, 'b) union -> ('c, 'd) union
+(** Alias for [Union.map] *)
 
 type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a
 (** Used for browsable-until structures. *)
 
+type ('a, 'b) eq = ('a, 'b) CSig.eq = Refl : ('a, 'a) eq
+
 val open_utf8_file_in : string -> in_channel
 (** Open an utf-8 encoded file and skip the byte-order mark if any. *)
diff --git a/library/declare.ml b/library/declare.ml
index 5f6f0fe4..c9992fff 100644
--- a/library/declare.ml
+++ b/library/declare.ml
@@ -9,7 +9,7 @@
 (** This module is about the low-level declaration of logical objects *)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Libnames
@@ -149,7 +149,7 @@ let cache_constant ((sp,kn), obj) =
       obj.cst_was_seff <- false;  
       if Global.exists_objlabel (Label.of_id (basename sp))
       then constant_of_kn kn
-      else Errors.anomaly Pp.(str"Ex seff not found: " ++ Id.print(basename sp))
+      else CErrors.anomaly Pp.(str"Ex seff not found: " ++ Id.print(basename sp))
     end else
       let () = check_exists sp in
       let kn', exported = Global.add_constant dir id obj.cst_decl in
@@ -158,7 +158,7 @@ let cache_constant ((sp,kn), obj) =
   assert (eq_constant kn' (constant_of_kn kn));
   Nametab.push (Nametab.Until 1) sp (ConstRef (constant_of_kn kn));
   let cst = Global.lookup_constant kn' in
-  add_section_constant (cst.const_proj <> None) kn' cst.const_hyps;
+  add_section_constant cst.const_polymorphic kn' cst.const_hyps;
   Dischargedhypsmap.set_discharged_hyps sp obj.cst_hyps;
   add_constant_kind (constant_of_kn kn) obj.cst_kind
 
@@ -325,7 +325,7 @@ let cache_inductive ((sp,kn),(dhyps,mie)) =
   let kn' = Global.add_mind dir id mie in
   assert (eq_mind kn' (mind_of_kn kn));
   let mind = Global.lookup_mind kn' in
-  add_section_kn kn' mind.mind_hyps;
+  add_section_kn mind.mind_polymorphic kn' mind.mind_hyps;
   Dischargedhypsmap.set_discharged_hyps sp dhyps;
   List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref) names
 
@@ -353,7 +353,8 @@ let dummy_inductive_entry (_,m) = ([],{
   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 })
+  mind_entry_private = None;
+})
 
 type inductive_obj = Dischargedhypsmap.discharged_hyps * mutual_inductive_entry
 
@@ -398,7 +399,7 @@ let declare_mind mie =
 let pr_rank i = pr_nth (i+1)
 
 let fixpoint_message indexes l =
-  Flags.if_verbose msg_info (match l with
+  Flags.if_verbose Feedback.msg_info (match l with
   | [] -> anomaly (Pp.str "no recursive definition")
   | [id] -> pr_id id ++ str " is recursively defined" ++
       (match indexes with
@@ -413,7 +414,7 @@ let fixpoint_message indexes l =
 		    | None -> mt ()))
 
 let cofixpoint_message l =
-  Flags.if_verbose msg_info (match l with
+  Flags.if_verbose Feedback.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 ++
@@ -423,15 +424,32 @@ let recursive_message isfix i l =
   (if isfix then fixpoint_message i else cofixpoint_message) l
 
 let definition_message id =
-  Flags.if_verbose msg_info (pr_id id ++ str " is defined")
+  Flags.if_verbose Feedback.msg_info (pr_id id ++ str " is defined")
 
 let assumption_message id =
-  Flags.if_verbose msg_info (pr_id id ++ str " is assumed")
+  (* Changing "assumed" to "declared", "assuming" referring more to
+  the type of the object than to the name of the object (see
+  discussion on coqdev: "Chapter 4 of the Reference Manual", 8/10/2015) *)
+  Flags.if_verbose Feedback.msg_info (pr_id id ++ str " is declared")
 
 (** Global universe names, in a different summary *)
 
-type universe_names =
-    (Univ.universe_level Idmap.t * Id.t Univ.LMap.t)
+type universe_context_decl = polymorphic * Univ.universe_context_set
+
+let cache_universe_context (p, ctx) =
+  Global.push_context_set p ctx;
+  if p then Lib.add_section_context ctx
+
+let input_universe_context : universe_context_decl -> Libobject.obj =
+  declare_object
+    { (default_object "Global universe context state") with
+      cache_function = (fun (na, pi) -> cache_universe_context pi);
+      load_function = (fun _ (_, pi) -> cache_universe_context pi);
+      discharge_function = (fun (_, (p, _ as x)) -> if p then None else Some x);
+      classify_function = (fun a -> Keep a) }
+
+let declare_universe_context poly ctx =
+  Lib.add_anonymous_leaf (input_universe_context (poly, ctx))
 
 (* Discharged or not *)
 type universe_decl = polymorphic * (Id.t * Univ.universe_level) list
@@ -440,13 +458,13 @@ let cache_universes (p, l) =
   let glob = Universes.global_universe_names () in
   let glob', ctx =
     List.fold_left (fun ((idl,lid),ctx) (id, lev) ->
-		    ((Idmap.add id lev idl, Univ.LMap.add lev id lid),
-		     Univ.ContextSet.add_universe lev ctx))
+        ((Idmap.add id (p, lev) idl,
+          Univ.LMap.add lev id lid),
+         Univ.ContextSet.add_universe lev ctx))
       (glob, Univ.ContextSet.empty) l
   in
-    Global.push_context_set p ctx;
-    if p then Lib.add_section_context ctx;
-    Universes.set_global_universe_names glob'
+  cache_universe_context (p, ctx);
+  Universes.set_global_universe_names glob'
 
 let input_universes : universe_decl -> Libobject.obj =
   declare_object
@@ -457,6 +475,12 @@ let input_universes : universe_decl -> Libobject.obj =
       classify_function = (fun a -> Keep a) }
 
 let do_universe poly l =
+  let in_section = Lib.sections_are_opened () in
+  let () =
+    if poly && not in_section then
+      user_err_loc (Loc.ghost, "Constraint",
+                    str"Cannot declare polymorphic universes outside sections")
+  in
   let l =
     List.map (fun (l, id) ->
 	      let lev = Universes.new_univ_level (Global.current_dirpath ()) in
@@ -467,8 +491,10 @@ let do_universe poly l =
 type constraint_decl = polymorphic * Univ.constraints
 
 let cache_constraints (na, (p, c)) =
-  Global.add_constraints c;
-  if p then Lib.add_section_context (Univ.ContextSet.add_constraints c Univ.ContextSet.empty)
+  let ctx =
+    Univ.ContextSet.add_constraints c
+      Univ.ContextSet.empty (* No declared universes here, just constraints *)
+  in cache_universe_context (p,ctx)
 
 let discharge_constraints (_, (p, c as a)) =
   if p then None else Some a
@@ -483,16 +509,40 @@ let input_constraints : constraint_decl -> Libobject.obj =
       classify_function = (fun a -> Keep a) }
 
 let do_constraint poly 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)
+  let open Misctypes in
+  let u_of_id x =
+    match x with
+    | GProp -> Loc.dummy_loc, (false, Univ.Level.prop)
+    | GSet -> Loc.dummy_loc, (false, Univ.Level.set)
+    | GType None ->
+       user_err_loc (Loc.dummy_loc, "Constraint",
+                     str "Cannot declare constraints on anonymous universes")
+    | GType (Some (loc, id)) ->
+       let id = Id.of_string id in
+       let names, _ = Universes.global_universe_names () in
+       try loc, Idmap.find id names
+       with Not_found ->
+         user_err_loc (loc, "Constraint", str "Undeclared universe " ++ pr_id id)
+  in
+  let in_section = Lib.sections_are_opened () in
+  let () =
+    if poly && not in_section then
+      user_err_loc (Loc.ghost, "Constraint",
+                    str"Cannot declare polymorphic constraints outside sections")
+  in
+  let check_poly loc p loc' p' =
+    if poly then ()
+    else if p || p' then
+      let loc = if p then loc else loc' in
+      user_err_loc (loc, "Constraint",
+                    str "Cannot declare a global constraint on " ++
+                    str "a polymorphic universe, use "
+                    ++ str "Polymorphic Constraint instead")
   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)
+     let ploc, (p, lu) = u_of_id l and rloc, (p', ru) = u_of_id r in
+     check_poly ploc p rloc p';
+     Univ.Constraint.add (lu, d, ru) acc)
     Univ.Constraint.empty l
   in
     Lib.add_anonymous_leaf (input_constraints (poly, constraints))
diff --git a/library/declare.mli b/library/declare.mli
index 8dd24d27..f70d594d 100644
--- a/library/declare.mli
+++ b/library/declare.mli
@@ -34,14 +34,6 @@ val declare_variable : variable -> variable_declaration -> object_name
 
 type constant_declaration = Safe_typing.private_constants constant_entry * logical_kind
 
-(** [declare_constant id cd] declares a global declaration
-   (constant/parameter) with name [id] in the current section; it returns
-   the full path of the declaration 
-
-  internal specify if the constant has been created by the kernel or by the
-  user, and in the former case, if its errors should be silent
-   
-   *)
 type internal_flag =
   | UserAutomaticRequest
   | InternalTacticRequest
@@ -53,6 +45,12 @@ val definition_entry : ?fix_exn:Future.fix_exn ->
   ?poly:polymorphic -> ?univs:Univ.universe_context ->
   ?eff:Safe_typing.private_constants -> constr -> Safe_typing.private_constants definition_entry
 
+(** [declare_constant id cd] declares a global declaration
+   (constant/parameter) with name [id] in the current section; it returns
+   the full path of the declaration
+
+  internal specify if the constant has been created by the kernel or by the
+  user, and in the former case, if its errors should be silent *)
 val declare_constant :
  ?internal:internal_flag -> ?local:bool -> Id.t -> ?export_seff:bool -> constant_declaration -> constant
 
@@ -89,7 +87,11 @@ val exists_name : Id.t -> bool
 
 
 
-(** Global universe names and constraints *)
+(** Global universe contexts, names and constraints *)
+
+val declare_universe_context : polymorphic -> Univ.universe_context_set -> unit
 
 val do_universe : polymorphic -> Id.t Loc.located list -> unit
-val do_constraint : polymorphic -> (Id.t Loc.located * Univ.constraint_type * Id.t Loc.located) list -> unit
+val do_constraint : polymorphic ->
+  (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list ->
+  unit
diff --git a/library/declaremods.ml b/library/declaremods.ml
index 04348415..b2806a1a 100644
--- a/library/declaremods.ml
+++ b/library/declaremods.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Declarations
@@ -371,7 +371,7 @@ 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");
+    assert (String.equal (object_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
@@ -642,7 +642,11 @@ let declare_module interp_modast id args res mexpr_o fs =
   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
+        let inl = inl2intopt ann in
+        let mte, _ = interp_modast env ModType mty in
+        (* We check immediately that mte is well-formed *)
+        let _ = Mod_typing.translate_mse env None inl mte in
+        Some mte, [], inl
     | Check mtys ->
 	None, build_subtypes interp_modast env mp arg_entries_r mtys,
         default_inline ()
@@ -727,7 +731,10 @@ let declare_modtype interp_modast id args mtys (mty,ann) fs =
   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 mte, _ = interp_modast env ModType mty in
+  (* We check immediately that mte is well-formed *)
+  let _ = Mod_typing.translate_mse env None inl mte in
+  let entry = params, mte 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
@@ -815,7 +822,7 @@ let protect_summaries f =
   try f fs
   with reraise ->
     (* Something wrong: undo the whole process *)
-    let reraise = Errors.push reraise in
+    let reraise = CErrors.push reraise in
     let () = Summary.unfreeze_summaries fs in
     iraise reraise
 
@@ -890,7 +897,13 @@ let start_library dir =
   Lib.start_compilation dir mp;
   Lib.add_frozen_state ()
 
+let end_library_hook = ref ignore
+let append_end_library_hook f =
+  let old_f = !end_library_hook in
+  end_library_hook := fun () -> old_f(); f ()
+
 let end_library ?except dir =
+  !end_library_hook();
   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
diff --git a/library/declaremods.mli b/library/declaremods.mli
index 2b440c08..3917fe8d 100644
--- a/library/declaremods.mli
+++ b/library/declaremods.mli
@@ -90,6 +90,9 @@ val end_library :
   ?except:Future.UUIDSet.t -> library_name ->
     Safe_typing.compiled_library * library_objects * Safe_typing.native_library
 
+(** append a function to be executed at end_library *)
+val append_end_library_hook : (unit -> unit) -> unit
+
 (** [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. Raises [Not_found] when [mp] is unknown
diff --git a/library/decls.ml b/library/decls.ml
index 0cd4ccb2..6e21880f 100644
--- a/library/decls.ml
+++ b/library/decls.ml
@@ -11,7 +11,6 @@
 
 open Util
 open Names
-open Context
 open Decl_kinds
 open Libnames
 
@@ -47,16 +46,20 @@ let constant_kind kn = Cmap.find kn !csttab
 
 (** Miscellaneous functions. *)
 
+open Context.Named.Declaration
+
 let initialize_named_context_for_proof () =
   let sign = Global.named_context () in
   List.fold_right
-    (fun (id,c,t as d) signv ->
-      let d = if variable_opacity id then (id,None,t) else d in
+    (fun d signv ->
+      let id = get_id d in
+      let d = if variable_opacity id then LocalAssum (id, get_type d) else d in
       Environ.push_named_context_val d signv) sign Environ.empty_named_context_val
 
 let last_section_hyps dir =
-  fold_named_context
-    (fun (id,_,_) sec_ids ->
+  Context.Named.fold_outside
+    (fun d sec_ids ->
+      let id = get_id d in
       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()))
diff --git a/library/global.ml b/library/global.ml
index 2398e92b..e748434d 100644
--- a/library/global.ml
+++ b/library/global.ml
@@ -42,7 +42,7 @@ let () =
 
 let assert_not_parsing () =
   if !Flags.we_are_parsing then
-    Errors.anomaly (
+    CErrors.anomaly (
       Pp.strbrk"The global environment cannot be accessed during parsing")
 
 let safe_env () = assert_not_parsing(); !global_env
@@ -84,6 +84,7 @@ let push_context_set b c = globalize0 (Safe_typing.push_context_set b c)
 let push_context b c = globalize0 (Safe_typing.push_context b c)
 
 let set_engagement c = globalize0 (Safe_typing.set_engagement c)
+let set_typing_flags c = globalize0 (Safe_typing.set_typing_flags c)
 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)
@@ -244,6 +245,14 @@ let is_template_polymorphic r =
   | IndRef ind -> Environ.template_polymorphic_ind ind env
   | ConstructRef cstr -> Environ.template_polymorphic_ind (inductive_of_constructor cstr) env
 
+let is_type_in_type r =
+  let env = env() in
+  match r with
+  | VarRef id -> false
+  | ConstRef c -> Environ.type_in_type_constant c env
+  | IndRef ind -> Environ.type_in_type_ind ind env
+  | ConstructRef cstr -> Environ.type_in_type_ind (inductive_of_constructor cstr) env
+
 let current_dirpath () = 
   Safe_typing.current_dirpath (safe_env ())
 
diff --git a/library/global.mli b/library/global.mli
index 9db30c8f..247ca20b 100644
--- a/library/global.mli
+++ b/library/global.mli
@@ -19,14 +19,15 @@ val env : unit -> Environ.env
 
 val env_is_initial : unit -> bool
 
-val universes : unit -> Univ.universes
+val universes : unit -> UGraph.t
 val named_context_val : unit -> Environ.named_context_val
-val named_context : unit -> Context.named_context
+val named_context : unit -> Context.Named.t
 
 (** {6 Enriching the global environment } *)
 
 (** Changing the (im)predicativity of the system *)
 val set_engagement : Declarations.engagement -> unit
+val set_typing_flags : Declarations.typing_flags -> unit
 
 (** Variables, Local definitions, constants, inductive types *)
 
@@ -73,7 +74,7 @@ val add_module_parameter :
 
 (** {6 Queries in the global environment } *)
 
-val lookup_named     : variable -> Context.named_declaration
+val lookup_named     : variable -> Context.Named.Declaration.t
 val lookup_constant  : constant -> Declarations.constant_body
 val lookup_inductive : inductive ->
   Declarations.mutual_inductive_body * Declarations.one_inductive_body
@@ -116,6 +117,7 @@ val is_joined_environment : unit -> bool
 
 val is_polymorphic : Globnames.global_reference -> bool
 val is_template_polymorphic : Globnames.global_reference -> bool
+val is_type_in_type : Globnames.global_reference -> bool
 
 val type_of_global_in_context : Environ.env -> 
   Globnames.global_reference -> Constr.types Univ.in_universe_context
diff --git a/library/globnames.ml b/library/globnames.ml
index 3ae44b2c..a78f5f13 100644
--- a/library/globnames.ml
+++ b/library/globnames.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Names
 open Term
 open Mod_subst
@@ -14,10 +14,10 @@ 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
+  | VarRef of variable           (** A reference to the section-context. *)
+  | ConstRef of constant         (** A reference to the environment. *)
+  | IndRef of inductive          (** A reference to an inductive type. *)
+  | ConstructRef of constructor  (** A reference to a constructor of an inductive type. *)
 
 let isVarRef = function VarRef _ -> true | _ -> false
 let isConstRef = function ConstRef _ -> true | _ -> false
@@ -107,17 +107,16 @@ let global_eq_gen eq_cst eq_ind eq_cons x y =
 let global_ord_gen ord_cst ord_ind ord_cons x y =
   if x == y then 0
   else match x, y with
+  | VarRef v1, VarRef v2 -> Id.compare v1 v2
+  | VarRef _, _ -> -1
+  | _, VarRef _ -> 1
   | ConstRef cx, ConstRef cy -> ord_cst cx cy
+  | ConstRef _, _ -> -1
+  | _, ConstRef _ -> 1
   | IndRef indx, IndRef indy -> ord_ind indx indy
+  | IndRef _, _ -> -1
+  | _ , IndRef _ -> 1
   | 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
diff --git a/library/globnames.mli b/library/globnames.mli
index f94f6216..f4956e3d 100644
--- a/library/globnames.mli
+++ b/library/globnames.mli
@@ -13,10 +13,10 @@ 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
+  | VarRef of variable           (** A reference to the section-context. *)
+  | ConstRef of constant         (** A reference to the environment. *)
+  | IndRef of inductive          (** A reference to an inductive type. *)
+  | ConstructRef of constructor  (** A reference to a constructor of an inductive type. *)
 
 val isVarRef : global_reference -> bool
 val isConstRef : global_reference -> bool
diff --git a/library/goptions.ml b/library/goptions.ml
index 5f6512e1..9dc0f405 100644
--- a/library/goptions.ml
+++ b/library/goptions.ml
@@ -9,7 +9,7 @@
 (* This module manages customization parameters at the vernacular level     *)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Libobject
 open Libnames
@@ -108,7 +108,8 @@ module MakeTable =
          (fun c -> t := MySet.remove c !t))
 
     let print_table table_name printer table =
-      pp (str table_name ++
+      Feedback.msg_notice
+        (str table_name ++
 	   (hov 0
 	      (if MySet.is_empty table then str " None" ++ fnl ()
                else MySet.fold
@@ -122,7 +123,7 @@ module MakeTable =
       method mem x =
 	let y = A.encode x in
         let answer = MySet.mem y !t in
-        msg_info (A.member_message y answer)
+        Feedback.msg_info (A.member_message y answer)
       method print = print_table A.title A.printer !t
     end
 
@@ -207,6 +208,10 @@ type 'a option_sig = {
   optread  : unit -> 'a;
   optwrite : 'a -> unit }
 
+type option_locality = OptLocal | OptDefault | OptGlobal
+
+type option_mod = OptSet | OptAppend
+
 module OptionOrd =
 struct
   type t = option_name
@@ -232,52 +237,57 @@ with Not_found ->
 open Libobject
 open Lib
 
-let declare_option cast uncast
+let warn_deprecated_option =
+  CWarnings.create ~name:"deprecated-option" ~category:"deprecated"
+         (fun key -> str "Option" ++ spc () ++ str (nickname key) ++
+                       strbrk " is deprecated")
+
+let get_locality = function
+  | Some true -> OptLocal
+  | Some false -> OptGlobal
+  | None -> OptDefault
+
+let declare_option cast uncast append ?(preprocess = fun x -> x)
   { optsync=sync; optdepr=depr; optname=name; optkey=key; optread=read; optwrite=write } =
   check_key key;
   let default = read() in
-  (* spiwack: I use two spaces in the nicknames of "local" and "global" objects.
-      That way I shouldn't collide with [nickname key] for any [key]. As [key]-s are
-       lists of strings *without* spaces. *)
-  let (write,lwrite,gwrite) = if sync then
-    let ldecl_obj = (* "Local": doesn't survive section or modules. *)
-      declare_object {(default_object ("L  "^nickname key)) with
-		       cache_function = (fun (_,v) -> write v);
-		       classify_function = (fun _ -> Dispose)}
-    in
-    let decl_obj = (* default locality: survives sections but not modules. *)
-      declare_object {(default_object (nickname key)) with
-		       cache_function = (fun (_,v) -> write v);
-		       classify_function = (fun _ -> Dispose);
-		       discharge_function = (fun (_,v) -> Some v)}
-    in
-    let gdecl_obj = (* "Global": survives section and modules. *)
-      declare_object {(default_object ("G  "^nickname key)) with
-		       cache_function = (fun (_,v) -> write v);
-		       classify_function = (fun v -> Substitute v);
-		       subst_function = (fun (_,v) -> v);
-		       discharge_function = (fun (_,v) -> Some v);
-		       load_function = (fun _ (_,v) -> write v)}
-    in
-    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 ,
-    begin fun v -> add_anonymous_leaf (gdecl_obj v) end
-  else write,write,write
-  in
-  let warn () =
-    if depr then
-      msg_warning (str "Option " ++ str (nickname key) ++ str " is deprecated")
+  let change =
+    if sync then
+      let _ = Summary.declare_summary (nickname key)
+        { Summary.freeze_function = (fun _ -> read ());
+          Summary.unfreeze_function = write;
+          Summary.init_function = (fun () -> write default) } in
+      let cache_options (_,(l,m,v)) =
+        match m with
+        | OptSet -> write v
+        | OptAppend -> write (append (read ()) v) in
+      let load_options i o = cache_options o in
+      let subst_options (subst,obj) = obj in
+      let discharge_options (_,(l,_,_ as o)) =
+        match l with OptLocal -> None | _ -> Some o in
+      let classify_options (l,_,_ as o) =
+        match l with OptGlobal -> Substitute o | _ -> Dispose in
+      let options : option_locality * option_mod * _ -> obj =
+        declare_object
+          { (default_object (nickname key)) with
+            load_function = load_options;
+            cache_function = cache_options;
+            subst_function = subst_options;
+            discharge_function = discharge_options;
+            classify_function = classify_options } in
+      (fun l m v -> let v = preprocess v in Lib.add_anonymous_leaf (options (l, m, v)))
+    else
+      (fun _ m v ->
+        let v = preprocess v in
+        match m with
+       | OptSet -> write v
+       | OptAppend -> write (append (read ()) v))
   in
+  let warn () = if depr then warn_deprecated_option key in
   let cread () = cast (read ()) in
-  let cwrite v = warn (); write (uncast v) in
-  let clwrite v = warn (); lwrite (uncast v) in
-  let cgwrite v = warn (); gwrite (uncast v) in
-  value_tab := OptionMap.add key (name, depr, (sync,cread,cwrite,clwrite,cgwrite)) !value_tab;
+  let cwrite l v = warn (); change l OptSet (uncast v) in
+  let cappend l v = warn (); change l OptAppend (uncast v) in
+  value_tab := OptionMap.add key (name, depr, (sync,cread,cwrite,cappend)) !value_tab;
   write
 
 type 'a write_function = 'a -> unit
@@ -286,36 +296,38 @@ let declare_int_option =
   declare_option
     (fun v -> IntValue v)
     (function IntValue v -> v | _ -> anomaly (Pp.str "async_option"))
+    (fun _ _ -> anomaly (Pp.str "async_option"))
 let declare_bool_option =
   declare_option
     (fun v -> BoolValue v)
     (function BoolValue v -> v | _ -> anomaly (Pp.str "async_option"))
+    (fun _ _ -> anomaly (Pp.str "async_option"))
 let declare_string_option =
   declare_option
     (fun v -> StringValue v)
     (function StringValue v -> v | _ -> anomaly (Pp.str "async_option"))
+    (fun x y -> x^","^y)
 let declare_stringopt_option =
   declare_option
     (fun v -> StringOptValue v)
     (function StringOptValue v -> v | _ -> anomaly (Pp.str "async_option"))
+    (fun _ _ -> anomaly (Pp.str "async_option"))
 
 (* 3- User accessible commands *)
 
 (* Setting values of options *)
 
+let warn_unknown_option =
+  CWarnings.create ~name:"unknown-option" ~category:"option"
+                   (fun key -> strbrk "There is no option " ++
+                                 str (nickname key) ++ str ".")
+
 let set_option_value locality check_and_cast key v =
-  let (name, depr, (_,read,write,lwrite,gwrite)) =
-    try get_option key
-    with Not_found ->
-      errorlabstrm "Goptions.set_option_value"
-        (str "There is no option " ++ str (nickname key) ++ str ".")
-  in
-  let write = match locality with
-    | None -> write
-    | Some true -> lwrite
-    | Some false -> gwrite
-  in
-  write (check_and_cast v (read ()))
+  let opt = try Some (get_option key) with Not_found -> None in
+  match opt with
+  | None -> warn_unknown_option key
+  | Some (name, depr, (_,read,write,append)) ->
+    write (get_locality locality) (check_and_cast v (read ()))
 
 let bad_type_error () = error "Bad type of value for this option."
 
@@ -345,13 +357,18 @@ let check_unset_value v = function
 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) -> msg_warning s
+  set_option_value locality check_bool_value key v
 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) -> msg_warning s
+  set_option_value locality check_unset_value key ()
+
+let set_string_option_append_value_gen locality key v =
+  let opt = try Some (get_option key) with Not_found -> None in
+  match opt with
+  | None -> warn_unknown_option key
+  | Some (name, depr, (_,read,write,append)) ->
+    append (get_locality locality) (check_string_value v (read ()))
 
 let set_int_option_value = set_int_option_value_gen None
 let set_bool_option_value = set_bool_option_value_gen None
@@ -361,27 +378,27 @@ let set_string_option_value = set_string_option_value_gen None
 
 let msg_option_value (name,v) =
   match v with
-    | BoolValue true  -> str "true"
-    | BoolValue false -> str "false"
+    | BoolValue true  -> str "on"
+    | BoolValue false -> str "off"
     | IntValue (Some n) -> int n
     | IntValue None   -> str "undefined"
-    | StringValue s   -> str s
+    | StringValue s   -> str "\"" ++ str s ++ str "\""
     | StringOptValue None   -> str"undefined"
-    | StringOptValue (Some s)   -> str s
+    | StringOptValue (Some s)   -> str "\"" ++ str s ++ str "\""
 (*     | IdentValue r    -> pr_global_env Id.Set.empty r *)
 
 let print_option_value key =
-  let (name, depr, (_,read,_,_,_)) = get_option key in
+  let (name, depr, (_,read,_,_)) = get_option key in
   let s = read () in
   match s with
     | BoolValue b ->
-	msg_info (str "The " ++ str name ++ str " mode is " ++ str (if b then "on" else "off"))
+	Feedback.msg_info (str "The " ++ str name ++ str " mode is " ++ str (if b then "on" else "off"))
     | _ ->
-	msg_info (str "Current value of " ++ str name ++ str " is " ++ msg_option_value (name, s))
+	Feedback.msg_info (str "Current value of " ++ str name ++ str " is " ++ msg_option_value (name, s))
 
 let get_tables () =
   let tables = !value_tab in
-  let fold key (name, depr, (sync,read,_,_,_)) accu =
+  let fold key (name, depr, (sync,read,_,_)) accu =
     let state = {
       opt_sync = sync;
       opt_name = name;
@@ -400,13 +417,13 @@ let print_tables () =
   in
   str "Synchronous options:" ++ fnl () ++
     OptionMap.fold
-      (fun key (name, depr, (sync,read,_,_,_)) p ->
+      (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 ->
+      (fun key (name, depr, (sync,read,_,_)) p ->
         if sync then p
         else p ++ print_option key name (read ()) depr)
       !value_tab (mt ()) ++
diff --git a/library/goptions.mli b/library/goptions.mli
index 26864503..3b3651f3 100644
--- a/library/goptions.mli
+++ b/library/goptions.mli
@@ -122,13 +122,19 @@ type 'a option_sig = {
 
 (** When an option is declared synchronous ([optsync] is [true]), the output is
    a synchronous write function. Otherwise it is [optwrite] *)
+(** The [preprocess] function is triggered before setting the option. It can be
+    used to emit a warning on certain values, and clean-up the final value. *)
 
 type 'a write_function = 'a -> unit
 
-val declare_int_option   : int option option_sig -> int option write_function
-val declare_bool_option  : bool option_sig   -> bool write_function
-val declare_string_option: string option_sig -> string write_function
-val declare_stringopt_option: string option option_sig -> string option write_function
+val declare_int_option   : ?preprocess:(int option -> int option) ->
+                           int option option_sig -> int option write_function
+val declare_bool_option  : ?preprocess:(bool -> bool) ->
+                           bool option_sig   -> bool write_function
+val declare_string_option: ?preprocess:(string -> string) ->
+                           string option_sig -> string write_function
+val declare_stringopt_option: ?preprocess:(string option -> string option) ->
+                              string option option_sig -> string option write_function
 
 
 (** {6 Special functions supposed to be used only in vernacentries.ml } *)
@@ -154,6 +160,7 @@ val get_ref_table :
 val set_int_option_value_gen    : bool option -> option_name -> int option -> unit
 val set_bool_option_value_gen   : bool option -> option_name -> bool   -> unit
 val set_string_option_value_gen : bool option -> option_name -> string -> unit
+val set_string_option_append_value_gen : bool option -> option_name -> string -> unit
 val unset_option_value_gen : bool option -> option_name -> unit
 
 val set_int_option_value    : option_name -> int option -> unit
diff --git a/library/heads.ml b/library/heads.ml
index 8124d347..02465f22 100644
--- a/library/heads.ml
+++ b/library/heads.ml
@@ -15,6 +15,7 @@ open Environ
 open Globnames
 open Libobject
 open Lib
+open Context.Named.Declaration
 
 (** Characterization of the head of a term *)
 
@@ -63,13 +64,13 @@ let kind_of_head env t =
       (try on_subterm k l b (variable_head id)
        with Not_found ->
         (* a goal variable *)
-        match pi2 (lookup_named id env) with
-        | Some c -> aux k l c b
-        | None -> NotImmediatelyComputableHead)
+        match lookup_named id env with
+        | LocalDef (_,c,_) -> aux k l c b
+        | LocalAssum _ -> NotImmediatelyComputableHead)
   | Const (cst,_) ->
       (try on_subterm k l b (constant_head cst)
        with Not_found ->
-         Errors.anomaly
+         CErrors.anomaly
            Pp.(str "constant not found in kind_of_head: " ++
                str (Names.Constant.to_string cst)))
   | Construct _ | CoFix _ ->
@@ -132,8 +133,8 @@ let compute_head = function
      | None -> RigidHead (RigidParameter cst)
      | Some c -> kind_of_head env c)
 | EvalVarRef id ->
-    (match pi2 (Global.lookup_named id) with
-     | Some c when not (Decls.variable_opacity id) ->
+    (match Global.lookup_named id with
+     | LocalDef (_,c,_) when not (Decls.variable_opacity id) ->
            kind_of_head (Global.env()) c
      | _ ->
            RigidHead (RigidVar id))
diff --git a/library/impargs.ml b/library/impargs.ml
index f5f6a3eb..828d652c 100644
--- a/library/impargs.ml
+++ b/library/impargs.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Globnames
@@ -68,15 +68,14 @@ let is_reversible_pattern_implicit_args () = !implicit_args.reversible_pattern
 let is_contextual_implicit_args () = !implicit_args.contextual
 let is_maximal_implicit_args () = !implicit_args.maximal
 
-let with_implicits flags f x =
+let with_implicit_protection f x =
   let oflags = !implicit_args in
   try
-    implicit_args := flags;
     let rslt = f x in
     implicit_args := oflags;
     rslt
   with reraise ->
-    let reraise = Errors.push reraise in
+    let reraise = CErrors.push reraise in
     let () = implicit_args := oflags in
     iraise reraise
 
@@ -165,6 +164,7 @@ let update pos rig (na,st) =
 
 (* modified is_rigid_reference with a truncated env *)
 let is_flexible_reference env bound depth f =
+  let open Context.Named.Declaration in
   match kind_of_term f with
     | Rel n when n >= bound+depth -> (* inductive type *) false
     | Rel n when n >= depth -> (* previous argument *) true
@@ -173,8 +173,7 @@ let is_flexible_reference env bound depth f =
         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
-        begin match value with None -> false | _ -> true end
+        Environ.lookup_named id env |> is_local_def
     | Ind _ | Construct _ -> false
     |  _ -> true
 
@@ -188,7 +187,7 @@ let is_reversible_pattern bound depth f l =
 (* Precondition: rels in env are for inductive types only *)
 let add_free_rels_until strict strongly_strict revpat bound env m pos acc =
   let rec frec rig (env,depth as ed) c =
-    let hd = if strict then whd_betadeltaiota env c else c in
+    let hd = if strict then whd_all 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) ->
@@ -234,13 +233,14 @@ let find_displayed_name_in all avoid na (_,b as envnames_b) =
 
 let compute_implicits_gen strict strongly_strict revpat contextual all env t =
   let rigid = ref true in
+  let open Context.Rel.Declaration in
   let rec aux env avoid n names t =
-    let t = whd_betadeltaiota env t in
+    let t = whd_all env t in
     match kind_of_term t with
       | Prod (na,a,b) ->
 	  let na',avoid' = find_displayed_name_in all avoid na (names,b) in
 	  add_free_rels_until strict strongly_strict revpat n env a (Hyp (n+1))
-            (aux (push_rel (na',None,a) env) avoid' (n+1) (na'::names) b)
+            (aux (push_rel (LocalAssum (na',a)) env) avoid' (n+1) (na'::names) b)
       | _ ->
 	  rigid := is_rigid_head t;
 	  let names = List.rev names in
@@ -249,10 +249,10 @@ let compute_implicits_gen strict strongly_strict revpat contextual all env t =
 	    add_free_rels_until strict strongly_strict revpat n env t Conclusion v
 	  else v
   in
-  match kind_of_term (whd_betadeltaiota env t) with
+  match kind_of_term (whd_all env t) with
     | Prod (na,a,b) ->
 	let na',avoid = find_displayed_name_in all [] na ([],b) in
-	let v = aux (push_rel (na',None,a) env) avoid 1 [na'] b in
+	let v = aux (push_rel (LocalAssum (na',a)) env) avoid 1 [na'] b in
 	!rigid, Array.to_list v
     | _ -> true, []
 
@@ -427,7 +427,7 @@ let compute_mib_implicits flags manual kn =
       (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))))
+	  Context.Rel.Declaration.LocalAssum (Name mip.mind_typename, 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 =
@@ -449,8 +449,8 @@ let compute_all_mib_implicits flags manual kn =
 
 let compute_var_implicits flags manual id =
   let env = Global.env () in
-  let (_,_,ty) = lookup_named id env in
-  compute_semi_auto_implicits env flags manual ty
+  let open Context.Named.Declaration in
+  compute_semi_auto_implicits env flags manual (get_type (lookup_named id env))
 
 (* Implicits of a global reference. *)
 
@@ -491,13 +491,15 @@ let implicits_of_global ref =
     let l = Refmap.find ref !implicits_table in
     try
       let rename_l = Arguments_renaming.arguments_names ref in
-      let rename imp name = match imp, name with
-       | Some (_, x,y), Name id -> Some (id, x,y)
-       | _ -> imp in
-      List.map2 (fun (t, il) rl -> t, List.map2 rename il rl) l rename_l
+      let rec rename implicits names = match implicits, names with
+        | [], _ -> []
+        | _, [] -> implicits
+        | Some (_, x,y) :: implicits, Name id :: names ->
+           Some (id, x,y) :: rename implicits names
+        | imp :: implicits, _ :: names -> imp :: rename implicits names
+      in
+      List.map (fun (t, il) -> t, rename il rename_l) l
     with Not_found -> l
-    | Invalid_argument _ ->
-        anomaly (Pp.str "renamings list and implicits list have different lenghts")
   with Not_found -> [DefaultImpArgs,[]]
 
 let cache_implicits_decl (ref,imps) =
@@ -525,12 +527,6 @@ let impls_of_context ctx =
   in
   List.rev_map map (List.filter is_set ctx)
 
-let section_segment_of_reference = function
-  | ConstRef con -> pi1 (section_segment_of_constant con)
-  | IndRef (kn,_) | ConstructRef ((kn,_),_) ->
-    pi1 (section_segment_of_mutual_inductive kn)
-  | _ -> []
-
 let adjust_side_condition p = function
   | LessArgsThan n -> LessArgsThan (n+p)
   | DefaultImpArgs -> DefaultImpArgs
@@ -544,7 +540,7 @@ let discharge_implicits (_,(req,l)) =
   | ImplLocal -> None
   | ImplInteractive (ref,flags,exp) ->
     (try
-      let vars = section_segment_of_reference ref in
+      let vars = variable_section_segment_of_reference ref in
       let ref' = if isVarRef ref then ref else pop_global_reference ref in
       let extra_impls = impls_of_context vars in
       let l' = [ref', List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in
@@ -562,7 +558,7 @@ let discharge_implicits (_,(req,l)) =
   | ImplMutualInductive (kn,flags) ->
     (try
       let l' = List.map (fun (gr, l) ->
-	let vars = section_segment_of_reference gr in
+	let vars = variable_section_segment_of_reference gr in
 	let extra_impls = impls_of_context vars in
 	((if isVarRef gr then gr else pop_global_reference gr),
 	 List.map (add_section_impls vars extra_impls) l)) l
@@ -663,7 +659,7 @@ let check_inclusion l =
   let rec aux = function
     | n1::(n2::_ as nl) ->
 	if n1 <= n2 then
-	  error "Sequences of implicit arguments must be of different lengths";
+	  error "Sequences of implicit arguments must be of different lengths.";
 	aux nl
     | _ -> () in
   aux (List.map (fun (imps,_) -> List.length imps) l)
diff --git a/library/impargs.mli b/library/impargs.mli
index 34e529ca..3919a519 100644
--- a/library/impargs.mli
+++ b/library/impargs.mli
@@ -29,8 +29,7 @@ val is_reversible_pattern_implicit_args : unit -> bool
 val is_contextual_implicit_args : unit -> bool
 val is_maximal_implicit_args : unit -> bool
 
-type implicits_flags
-val with_implicits : implicits_flags -> ('a -> 'b) -> 'a -> 'b
+val with_implicit_protection : ('a -> 'b) -> 'a -> 'b
 
 (** {6 ... } *)
 (** An [implicits_list] is a list of positions telling which arguments
@@ -136,14 +135,5 @@ val select_impargs_size : int -> implicits_list list -> implicit_status list
 
 val select_stronger_impargs : implicits_list list -> implicit_status list
 
-type implicit_interactive_request
-
-type implicit_discharge_request =
-  | ImplLocal
-  | ImplConstant of constant * implicits_flags
-  | ImplMutualInductive of mutual_inductive * implicits_flags
-  | 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
index 0c167494..057dc3b6 100644
--- a/library/keys.ml
+++ b/library/keys.ml
@@ -12,35 +12,31 @@ open Globnames
 open Term
 open Libobject
 
-type key = 
+type key =
   | KGlob of global_reference
-  | KLam 
+  | KLam
   | KLet
   | KProd
   | KSort
-  | KEvar
-  | KCase 
-  | KFix 
+  | KCase
+  | KFix
   | KCoFix
-  | KRel 
-  | KMeta
+  | KRel
 
 module KeyOrdered = struct
   type t = key
 
   let hash gr =
     match gr with
-    | KGlob gr -> 10 + RefOrdered.hash gr
+    | KGlob gr -> 8 + RefOrdered.hash gr
     | KLam -> 0
     | KLet -> 1
     | KProd -> 2
     | KSort -> 3
-    | KEvar -> 4
-    | KCase -> 5
-    | KFix -> 6
-    | KCoFix -> 7
-    | KRel -> 8
-    | KMeta -> 9
+    | KCase -> 4
+    | KFix -> 5
+    | KCoFix -> 6
+    | KRel -> 7
 
   let compare gr1 gr2 =
     match gr1, gr2 with
@@ -62,8 +58,6 @@ 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 =
@@ -153,12 +147,10 @@ let pr_key pr_global = function
   | 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)
diff --git a/library/kindops.ml b/library/kindops.ml
index c634193d..21b1bec3 100644
--- a/library/kindops.ml
+++ b/library/kindops.ml
@@ -25,7 +25,7 @@ let string_of_theorem_kind = function
 
 let string_of_definition_kind def =
   let (locality, poly, kind) = def in
-  let error () = Errors.anomaly (Pp.str "Internal definition kind") in
+  let error () = CErrors.anomaly (Pp.str "Internal definition kind") in
   match kind with
   | Definition ->
     begin match locality with
@@ -64,4 +64,4 @@ let string_of_definition_kind def =
     | Global -> "Global Instance"
     end
   | (StructureComponent|Scheme|CoFixpoint|Fixpoint|IdentityCoercion|Method) ->
-    Errors.anomaly (Pp.str "Internal definition kind")
+    CErrors.anomaly (Pp.str "Internal definition kind")
diff --git a/library/lib.ml b/library/lib.ml
index ff892916..f680ecee 100644
--- a/library/lib.ml
+++ b/library/lib.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Libnames
 open Globnames
@@ -231,11 +231,16 @@ let add_leaves id objs =
   List.iter add_obj objs;
   oname
 
-let add_anonymous_leaf obj =
+let add_anonymous_leaf ?(cache_first = true) obj =
   let id = anonymous_id () in
   let oname = make_oname id in
-  cache_object (oname,obj);
-  add_entry oname (Leaf obj)
+  if cache_first then begin
+    cache_object (oname,obj);
+    add_entry oname (Leaf obj)
+  end else begin
+    add_entry oname (Leaf obj);
+    cache_object (oname,obj)
+  end
 
 let add_frozen_state () =
   add_anonymous_entry
@@ -408,21 +413,30 @@ let add_section () =
   sectab := ([],(Names.Cmap.empty,Names.Mindmap.empty),
                 (Names.Cmap.empty,Names.Mindmap.empty)) :: !sectab
 
+let check_same_poly p vars =
+  let pred = function Context _ -> p = false | Variable (_, _, poly, _) -> p != poly in
+  if List.exists pred vars then
+    error "Cannot mix universe polymorphic and monomorphic declarations in sections."
+
 let add_section_variable id impl poly ctx =
   match !sectab with
     | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *)
     | (vars,repl,abs)::sl ->
-	sectab := (Variable (id,impl,poly,ctx)::vars,repl,abs)::sl
+       List.iter (fun tab -> check_same_poly poly (pi1 tab)) !sectab;
+       sectab := (Variable (id,impl,poly,ctx)::vars,repl,abs)::sl
 
 let add_section_context ctx =
   match !sectab with
     | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *)
     | (vars,repl,abs)::sl ->
-	sectab := (Context ctx :: vars,repl,abs)::sl
+       check_same_poly true vars;
+       sectab := (Context ctx :: vars,repl,abs)::sl
 
 let extract_hyps (secs,ohyps) =
+  let open Context.Named.Declaration in
   let rec aux = function
-    | (Variable (id,impl,poly,ctx)::idl,(id',b,t)::hyps) when Names.Id.equal id id' ->
+    | (Variable (id,impl,poly,ctx)::idl, decl::hyps) when Names.Id.equal id (get_id decl) ->
+      let (id',b,t) = to_tuple decl in
       let l, r = aux (idl,hyps) in 
 	(id',impl,b,t) :: l, if poly then Univ.ContextSet.union r ctx else r
     | (Variable (_,_,poly,ctx)::idl,hyps) ->
@@ -441,12 +455,16 @@ let instance_from_variable_context sign =
     | [] -> [] in
   Array.of_list (inst_rec sign)
 
-let named_of_variable_context ctx = List.map (fun (id,_,b,t) -> (id,b,t)) ctx
+let named_of_variable_context ctx = let open Context.Named.Declaration in
+                                    List.map (function id,_,None,t -> LocalAssum (id,t)
+                                                     | id,_,Some b,t -> LocalDef (id,b,t))
+                                             ctx
   
-let add_section_replacement f g hyps =
+let add_section_replacement f g poly hyps =
   match !sectab with
   | [] -> ()
   | (vars,exps,abs)::sl ->
+    let () = check_same_poly poly vars 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
@@ -454,13 +472,13 @@ let add_section_replacement f g hyps =
     sectab := (vars,f (Univ.UContext.instance ctx,args) exps,
 	      g (sechyps,subst,ctx) abs)::sl
 
-let add_section_kn kn =
+let add_section_kn poly kn =
   let f x (l1,l2) = (l1,Names.Mindmap.add kn x l2) in
-    add_section_replacement f f
+    add_section_replacement f f poly
 
-let add_section_constant is_projection kn =
+let add_section_constant poly kn =
   let f x (l1,l2) = (Names.Cmap.add kn x l1,l2) in
-    add_section_replacement f f
+    add_section_replacement f f poly
 
 let replacement_context () = pi2 (List.hd !sectab)
 
@@ -470,6 +488,12 @@ let section_segment_of_constant con =
 let section_segment_of_mutual_inductive kn =
   Names.Mindmap.find kn (snd (pi3 (List.hd !sectab)))
 
+let variable_section_segment_of_reference = function
+  | ConstRef con -> pi1 (section_segment_of_constant con)
+  | IndRef (kn,_) | ConstructRef ((kn,_),_) ->
+      pi1 (section_segment_of_mutual_inductive kn)
+  | _ -> []
+                     
 let section_instance = function
   | VarRef id ->
      let eq = function
@@ -487,13 +511,6 @@ let section_instance = function
 let is_in_section ref =
   try ignore (section_instance ref); true with Not_found -> false
 
-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. *)
 
@@ -594,15 +611,6 @@ let rec dp_of_mp = function
   |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]
@@ -614,20 +622,6 @@ 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 (Pp.str "remove_section_part not supported on local variables")
-  | _ ->
-      if is_dirpath_prefix_of dir (cwd ()) then
-        (* Not yet (fully) discharged *)
-        pop_dirpath_n (sections_depth ()) (cwd ())
-      else
-	(* Theorem/Lemma outside its outer section of definition *)
-	dir
-
 (************************)
 (* Discharging names *)
 
diff --git a/library/lib.mli b/library/lib.mli
index 29fc7cd2..a8e110c6 100644
--- a/library/lib.mli
+++ b/library/lib.mli
@@ -54,7 +54,7 @@ val segment_of_objects :
   current list of operations (most recent ones coming first). *)
 
 val add_leaf : Names.Id.t -> Libobject.obj -> Libnames.object_name
-val add_anonymous_leaf : Libobject.obj -> unit
+val add_anonymous_leaf : ?cache_first:bool -> Libobject.obj -> unit
 val pull_to_head : Libnames.object_name -> unit
 
 (** this operation adds all objects with the same name and calls [load_object]
@@ -138,10 +138,8 @@ 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.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 } *)
 
@@ -168,19 +166,21 @@ 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.Id.t array
-val named_of_variable_context : variable_context -> Context.named_context
+val named_of_variable_context : variable_context -> Context.Named.t
 
 val section_segment_of_constant : Names.constant -> abstr_info
 val section_segment_of_mutual_inductive: Names.mutual_inductive -> abstr_info
-
+val variable_section_segment_of_reference : Globnames.global_reference -> variable_context
+                                                                                                     
 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.Id.t -> Decl_kinds.binding_kind -> Decl_kinds.polymorphic -> Univ.universe_context_set -> unit
 val add_section_context : Univ.universe_context_set -> unit
-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 add_section_constant : Decl_kinds.polymorphic ->
+  Names.constant -> Context.Named.t -> unit
+val add_section_kn : Decl_kinds.polymorphic ->
+  Names.mutual_inductive -> Context.Named.t -> unit
 val replacement_context : unit -> Opaqueproof.work_list
 
 (** {6 Discharge: decrease the section level if in the current section } *)
@@ -189,10 +189,3 @@ val discharge_kn :  Names.mutual_inductive -> Names.mutual_inductive
 val discharge_con : Names.constant -> Names.constant
 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 a2f22b2e..dd74e192 100644
--- a/library/libnames.ml
+++ b/library/libnames.ml
@@ -7,13 +7,13 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 
 (**********************************************)
 
-let pr_dirpath sl = (str (DirPath.to_string sl))
+let pr_dirpath sl = str (DirPath.to_string sl)
 
 (*s Operations on dirpaths *)
 
@@ -197,7 +197,7 @@ let string_of_reference = function
 
 let pr_reference = function
   | Qualid (_,qid) -> pr_qualid qid
-  | Ident (_,id) -> str (Id.to_string id)
+  | Ident (_,id) -> Id.print id
 
 let loc_of_reference = function
   | Qualid (loc,qid) -> loc
diff --git a/library/libobject.ml b/library/libobject.ml
index 706e3991..caa03c85 100644
--- a/library/libobject.ml
+++ b/library/libobject.ml
@@ -8,18 +8,9 @@
 
 open Libnames
 open Pp
+open Util
 
-(* 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
-   wants to work with restricted Coq programs that have only parts of
-   the full capabilities, but may still be able to work correctly for
-   limited purposes.  One example is for the graphical interface, that uses
-   such a limited Coq process to do only parsing.  It loads .vo files, but
-   is only interested in loading the grammar rule definitions. *)
-
-let relax_flag = ref false;;
-
-let relax b = relax_flag := b;;
+module Dyn = Dyn.Make(struct end)
 
 type 'a substitutivity =
     Dispose | Substitute of 'a | Keep of 'a | Anticipate of 'a
@@ -40,7 +31,7 @@ let default_object s = {
   load_function = (fun _ _ -> ());
   open_function = (fun _ _ -> ());
   subst_function = (fun _ ->
-    Errors.anomaly (str "The object " ++ str s ++ str " does not know how to substitute!"));
+    CErrors.anomaly (str "The object " ++ str s ++ str " does not know how to substitute!"));
   classify_function = (fun obj -> Keep obj);
   discharge_function = (fun _ -> None);
   rebuild_function = (fun x -> x)}
@@ -70,15 +61,14 @@ type dynamic_object_declaration = {
   dyn_discharge_function : object_name * obj -> obj option;
   dyn_rebuild_function : obj -> obj }
 
-let object_tag = Dyn.tag
-let object_has_tag = Dyn.has_tag
+let object_tag (Dyn.Dyn (t, _)) = Dyn.repr t
 
 let cache_tab =
   (Hashtbl.create 17 : (string,dynamic_object_declaration) Hashtbl.t)
 
 let declare_object_full odecl =
   let na = odecl.object_name in
-  let (infun,outfun) = Dyn.create na in
+  let (infun, outfun) = Dyn.Easy.make_dyn na in
   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)
@@ -107,36 +97,21 @@ let declare_object_full odecl =
 
 let declare_object odecl =
   try fst (declare_object_full odecl)
-  with e -> Errors.fatal_error (Errors.print e) (Errors.is_anomaly e)
+  with e -> CErrors.fatal_error (CErrors.print e) (CErrors.is_anomaly e)
 let declare_object_full odecl =
   try declare_object_full odecl
-  with e -> Errors.fatal_error (Errors.print e) (Errors.is_anomaly e)
-
-let missing_tab = (Hashtbl.create 17 : (string, unit) Hashtbl.t)
+  with e -> CErrors.fatal_error (CErrors.print e) (CErrors.is_anomaly e)
 
 (* this function describes how the cache, load, open, and export functions
-   are triggered.  In relaxed mode, this function just return a meaningless
-   value instead of raising an exception when they fail. *)
+   are triggered. *)
 
 let apply_dyn_fun deflt f lobj =
   let tag = object_tag lobj in
-  try
-    let dodecl =
-      try
-        Hashtbl.find cache_tab tag
-      with Not_found ->
-        failwith "local to_apply_dyn_fun" in
-    f dodecl
-  with
-    Failure "local to_apply_dyn_fun" ->
-      if not (!relax_flag || Hashtbl.mem missing_tab tag) then
-        begin
-          Pp.msg_warning
-	    (Pp.str ("Cannot find library functions for an object with tag "
-                      ^ tag ^ " (a plugin may be missing)"));
-          Hashtbl.add missing_tab tag ()
-        end;
-      deflt
+  let dodecl =
+    try Hashtbl.find cache_tab tag
+    with Not_found -> assert false
+  in
+  f dodecl
 
 let cache_object ((_,lobj) as node) =
   apply_dyn_fun () (fun d -> d.dyn_cache_function node) lobj
@@ -158,3 +133,5 @@ let discharge_object ((_,lobj) as node) =
 
 let rebuild_object lobj =
   apply_dyn_fun lobj (fun d -> d.dyn_rebuild_function lobj) lobj
+
+let dump = Dyn.dump
diff --git a/library/libobject.mli b/library/libobject.mli
index f3880a43..51b9af05 100644
--- a/library/libobject.mli
+++ b/library/libobject.mli
@@ -99,7 +99,6 @@ 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
@@ -108,4 +107,7 @@ val subst_object : substitution * obj -> obj
 val classify_object : obj -> obj substitutivity
 val discharge_object : object_name * obj -> obj option
 val rebuild_object : obj -> obj
-val relax : bool -> unit
+
+(** {6 Debug} *)
+
+val dump : unit -> (int * string) list
diff --git a/library/library.ml b/library/library.ml
index 79e5792c..d44f796a 100644
--- a/library/library.ml
+++ b/library/library.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 
 open Names
@@ -35,7 +35,7 @@ module Delayed :
 sig
 
 type 'a delayed
-val in_delayed : string -> in_channel -> 'a delayed
+val in_delayed : string -> in_channel -> 'a delayed * Digest.t
 val fetch_delayed : 'a delayed -> 'a
 
 end =
@@ -50,7 +50,7 @@ type 'a delayed = {
 let in_delayed f ch =
   let pos = pos_in ch in
   let _, digest = System.skip_in_segment f ch in
-  { del_file = f; del_digest = digest; del_off = pos; }
+  ({ del_file = f; del_digest = digest; del_off = pos; }, digest)
 
 (** Fetching a table of opaque terms at position [pos] in file [f],
     expecting to find first a copy of [digest]. *)
@@ -64,7 +64,7 @@ let fetch_delayed del =
     let () = close_in ch in
     if not (String.equal digest digest') then raise (Faulty f);
     obj
-  with e when Errors.noncritical e -> raise (Faulty f)
+  with e when CErrors.noncritical e -> raise (Faulty f)
 
 end
 
@@ -132,7 +132,7 @@ let try_find_library dir =
   try find_library dir
   with Not_found ->
     errorlabstrm "Library.find_library"
-      (str "Unknown library " ++ str (DirPath.to_string dir))
+      (str "Unknown library " ++ pr_dirpath dir)
 
 let register_library_filename dir f =
   (* Not synchronized: overwrite the previous binding if one existed *)
@@ -171,9 +171,8 @@ let register_loaded_library m =
     let prefix = Nativecode.mod_uid_of_dirpath libname ^ "." in
     let f = prefix ^ "cmo" in
     let f = Dynlink.adapt_filename f in
-    (* This will not produce errors or warnings if the native compiler was
-       not enabled *)
-    Nativelib.link_library ~prefix ~dirname ~basename:f
+    if not Coq_config.no_native_compiler then
+      Nativelib.link_library ~prefix ~dirname ~basename:f
   in
   let rec aux = function
     | [] -> link m; [libname]
@@ -272,6 +271,12 @@ exception LibUnmappedDir
 exception LibNotFound
 type library_location = LibLoaded | LibInPath
 
+let warn_several_object_files =
+  CWarnings.create ~name:"several-object-files" ~category:"require"
+         (fun (vi, vo) -> str"Loading" ++ spc () ++ str vi ++
+                            strbrk " instead of " ++ str vo ++
+                            strbrk " because it is more recent")
+
 let locate_absolute_library dir =
   (* Search in loadpath *)
   let pref, base = split_dirpath dir in
@@ -286,28 +291,17 @@ let locate_absolute_library dir =
     with Not_found -> [] in
   match find ".vo" @ find ".vio" with
   | [] -> raise LibNotFound
-  | [file] -> dir, file
+  | [file] -> 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
+    warn_several_object_files (vi, vo);
+    vi
+  | [vo;vi] -> vo
   | _ -> assert false
 
 let locate_qualified_library ?root ?(warn = true) qid =
   (* Search library in loadpath *)
   let dir, base = repr_qualid qid in
-  let loadpath = match root with
-  | None -> Loadpath.expand_path dir
-  | Some root ->
-    let filter path =
-      if is_dirpath_prefix_of root path then
-        let path = drop_dirpath_prefix root path in
-        is_dirpath_suffix_of dir path
-      else false
-    in
-    Loadpath.filter_path filter
-  in
+  let loadpath = Loadpath.expand_path ?root dir in
   let () = match loadpath with [] -> raise LibUnmappedDir | _ -> () in
   let find ext =
     try
@@ -322,8 +316,7 @@ let locate_qualified_library ?root ?(warn = true) qid =
     | [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");
+      warn_several_object_files (vi, vo);
        lpath_vi, vi
     | [lpath_vo, vo; _ ] -> lpath_vo, vo
     | _ -> assert false
@@ -381,7 +374,7 @@ let access_table what tables dp i =
     | Fetched t -> t
     | ToFetch f ->
       let dir_path = Names.DirPath.to_string dp in
-      Flags.if_verbose msg_info (str"Fetching " ++ str what++str" from disk for " ++ str dir_path);
+      Flags.if_verbose Feedback.msg_info (str"Fetching " ++ str what++str" from disk for " ++ str dir_path);
       let t =
         try fetch_delayed f
         with Faulty f ->
@@ -438,56 +431,59 @@ let mk_summary m = {
 let intern_from_file f =
   let ch = raw_intern_library f in
   let (lsd : seg_sum), _, digest_lsd = System.marshal_in_segment f ch in
-  let (lmd : seg_lib delayed) = in_delayed f ch in
+  let ((lmd : seg_lib delayed), digest_lmd) = in_delayed 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 _ = System.skip_in_segment f ch in
-  let (del_opaque : seg_proofs delayed) = in_delayed f ch in
+  let ((del_opaque : seg_proofs delayed),_) = in_delayed f ch in
   close_in ch;
   register_library_filename lsd.md_name f;
   add_opaque_table lsd.md_name (ToFetch del_opaque);
   let open Safe_typing in
   match univs with
-  | None -> mk_library lsd lmd (Dvo_or_vi digest_lsd) Univ.ContextSet.empty
+  | None -> mk_library lsd lmd (Dvo_or_vi digest_lmd) Univ.ContextSet.empty
   | Some (utab,uall,true) ->
       add_univ_table lsd.md_name (Fetched utab);
-      mk_library lsd lmd (Dvivo (digest_lsd,digest_u)) uall
+      mk_library lsd lmd (Dvivo (digest_lmd,digest_u)) uall
   | Some (utab,_,false) ->
       add_univ_table lsd.md_name (Fetched utab);
-      mk_library lsd lmd (Dvo_or_vi digest_lsd) Univ.ContextSet.empty
+      mk_library lsd lmd (Dvo_or_vi digest_lmd) Univ.ContextSet.empty
 
 module DPMap = Map.Make(DirPath)
 
 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).libsum_digests, (needed, contents)
   with Not_found ->
   (* Look if already listed and consequently its dependencies too *)
   try (DPMap.find dir contents).library_digests, (needed, contents)
   with Not_found ->
+  Feedback.feedback(Feedback.FileDependency (from, DirPath.to_string dir));
   (* [dir] is an absolute name which matches [f] which must be in loadpath *)
+  let f = match f with Some f -> f | None -> try_locate_absolute_library dir in
   let m = intern_from_file f in
   if not (DirPath.equal dir m.library_name) then
     errorlabstrm "load_physical_library"
       (str "The file " ++ str f ++ str " contains library" ++ spc () ++
        pr_dirpath m.library_name ++ spc () ++ str "and not library" ++
        spc() ++ pr_dirpath dir);
-  Pp.feedback(Feedback.FileLoaded(DirPath.to_string dir, f));
-  m.library_digests, intern_library_deps (needed, contents) dir m (Some f)
+  Feedback.feedback (Feedback.FileLoaded(DirPath.to_string dir, f));
+  m.library_digests, intern_library_deps (needed, contents) dir m f
 
 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 from libs (dir,d) =
-  let digest, libs = intern_library libs (try_locate_absolute_library dir) from in
+  let digest, libs = intern_library libs (dir, None) (Some from) in
   if not (Safe_typing.digest_match ~actual:digest ~required:d) then
-    errorlabstrm "" (str "Compiled library " ++ str (DirPath.to_string caller) ++ str ".vo makes inconsistent assumptions over library " ++ str (DirPath.to_string dir));
+    errorlabstrm "" (str "Compiled library " ++ pr_dirpath caller ++
+    str " (in file " ++ str from ++ str ") makes inconsistent assumptions \
+    over library " ++ pr_dirpath dir);
   libs
 
-let rec_intern_library libs mref =
-  let _, libs = intern_library libs mref None in
+let rec_intern_library libs (dir, f) =
+  let _, libs = intern_library libs (dir, Some f) None in
   libs
 
 let native_name_from_filename f =
@@ -557,12 +553,20 @@ let in_require : require_obj -> obj =
 
 let (f_xml_require, xml_require) = Hook.make ~default:ignore ()
 
+let warn_require_in_module =
+  CWarnings.create ~name:"require-in-module" ~category:"deprecated"
+                   (fun () -> strbrk "Require inside a module is" ++
+                              strbrk " deprecated and strongly discouraged. " ++
+                              strbrk "You can Require a module at toplevel " ++
+                              strbrk "and optionally Import it inside another one.")
+
 let require_library_from_dirpath modrefl export =
   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
+        warn_require_in_module ();
 	add_anonymous_leaf (in_require (needed,modrefl,None));
 	Option.iter (fun exp ->
 	  add_anonymous_leaf (in_import_library (modrefl,exp)))
@@ -579,7 +583,7 @@ let safe_locate_module (loc,qid) =
   try Nametab.locate_module qid
   with Not_found ->
     user_err_loc
-      (loc,"import_library", str (string_of_qualid qid) ++ str " is not a module")
+      (loc,"import_library", pr_qualid qid ++ str " is not a module")
 
 let import_module export modl =
   (* Optimization: libraries in a raw in the list are imported
@@ -604,7 +608,7 @@ let import_module export modl =
             try Declaremods.import_module export mp; aux [] l
             with Not_found ->
               user_err_loc (loc,"import_library",
-                str (string_of_qualid dir) ++ str " is not a module"))
+                pr_qualid dir ++ str " is not a module"))
     | [] -> flush acc
   in aux [] modl
 
@@ -614,9 +618,9 @@ let import_module export modl =
 let check_coq_overwriting p id =
   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
+  if not !Flags.boot && not is_empty && Id.equal (List.last l) coq_root then
     errorlabstrm ""
-      (str "Cannot build module " ++ str (DirPath.to_string p) ++ str "." ++ pr_id id ++ str "." ++ spc () ++
+      (str "Cannot build module " ++ pr_dirpath p ++ str "." ++ pr_id id ++ str "." ++ spc () ++
       str "it starts with prefix \"Coq\" which is reserved for the Coq library.")
 
 (* Verifies that a string starts by a letter and do not contain
@@ -638,17 +642,14 @@ let check_module_name s =
         done
     | c -> err c
 
-let start_library f =
-  let () = if not (Sys.file_exists f) then
-    errorlabstrm "" (hov 0 (str "Can't find file" ++ spc () ++ str f))
-  in
+let start_library fo =
   let ldir0 =
     try
-      let lp = Loadpath.find_load_path (Filename.dirname f) in
+      let lp = Loadpath.find_load_path (Filename.dirname fo) in
       Loadpath.logical lp
     with Not_found -> Nameops.default_root_prefix
   in
-  let file = Filename.chop_extension (Filename.basename f) in
+  let file = Filename.chop_extension (Filename.basename fo) in
   let id = Id.of_string file in
   check_module_name file;
   check_coq_overwriting ldir0 id;
@@ -703,12 +704,13 @@ let error_recursively_dependent_library dir =
    writing the content and computing the checksum... *)
 
 let save_library_to ?todo dir f otab =
-  let f, except = match todo with
+  let except = match todo with
     | None ->
         assert(!Flags.compilation_mode = Flags.BuildVo);
-        f ^ "o", Future.UUIDSet.empty
+        assert(Filename.check_suffix f ".vo");
+        Future.UUIDSet.empty
     | Some (l,_) ->
-        f ^ "io",
+        assert(Filename.check_suffix f ".vio");
         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
@@ -732,7 +734,7 @@ let save_library_to ?todo dir f otab =
       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"
+    if not(is_done_or_todo i x) then CErrors.errorlabstrm "library"
       Pp.(str"Proof object "++int i++str" is not checked nor to be checked"))
     opaque_table;
   let sd = {
@@ -764,8 +766,8 @@ let save_library_to ?todo dir f otab =
       if not (Nativelib.compile_library dir ast fn) then
 	error "Could not compile the library to native code."
    with reraise ->
-    let reraise = Errors.push reraise in
-    let () = msg_warning (str "Removed file " ++ str f') in
+    let reraise = CErrors.push reraise in
+    let () = Feedback.msg_warning (str "Removed file " ++ str f') in
     let () = close_out ch in
     let () = Sys.remove f' in
     iraise reraise
@@ -781,13 +783,6 @@ let save_library_raw f sum lib univs proofs =
   System.marshal_out_segment f' ch (proofs     : seg_proofs);
   close_out ch
 
-(************************************************************************)
-(*s Display the memory use of a library. *)
-
-open Printf
-
-let mem s = Pp.mt ()
-
 module StringOrd = struct type t = string let compare = String.compare end
 module StringSet = Set.Make(StringOrd)
 
diff --git a/library/library.mli b/library/library.mli
index 25c9604c..b9044b60 100644
--- a/library/library.mli
+++ b/library/library.mli
@@ -37,9 +37,9 @@ type seg_proofs = Term.constr Future.computation array
    an export otherwise just a simple import *)
 val import_module : bool -> qualid located list -> unit
 
-(** Start the compilation of a file as a library. The argument must be an
-    existing file on the system, and the returned path is the associated
-    absolute logical path of the library. *)
+(** Start the compilation of a file as a library. The first argument must be
+    output file, and the 
+    returned path is the associated absolute logical path of the library. *)
 val start_library : CUnix.physical_path -> DirPath.t
 
 (** End the compilation of a library and save it to a ".vo" file *)
@@ -85,8 +85,5 @@ val locate_qualified_library :
 
 *)
 
-(** {6 Statistics: display the memory use of a library. } *)
-val mem : DirPath.t -> Pp.std_ppcmds
-
 (** {6 Native compiler. } *)
 val native_name_from_filename : string -> string
diff --git a/library/loadpath.ml b/library/loadpath.ml
index 78f8dd25..d03c6c55 100644
--- a/library/loadpath.ml
+++ b/library/loadpath.ml
@@ -8,7 +8,7 @@
 
 open Pp
 open Util
-open Errors
+open CErrors
 open Names
 open Libnames
 
@@ -50,6 +50,13 @@ let remove_load_path dir =
   let filter p = not (String.equal p.path_physical dir) in
   load_paths := List.filter filter !load_paths
 
+let warn_overriding_logical_loadpath =
+  CWarnings.create ~name:"overriding-logical-loadpath" ~category:"loadpath"
+         (fun (phys_path, old_path, coq_path) ->
+          str phys_path ++ strbrk " was previously bound to " ++
+            pr_dirpath old_path ++ strbrk "; it is remapped to " ++
+            pr_dirpath coq_path)
+
 let add_load_path phys_path coq_path ~implicit =
   let phys_path = CUnix.canonical_path_name phys_path in
   let filter p = String.equal p.path_physical phys_path in
@@ -65,17 +72,12 @@ let add_load_path phys_path coq_path ~implicit =
     let replace =
       if DirPath.equal coq_path old_path then
         implicit <> old_implicit
-      else if DirPath.equal coq_path (Nameops.default_root_prefix)
-              && String.equal phys_path (CUnix.canonical_path_name Filename.current_dir_name) then
-        false (* This is the default "-I ." path, don't override the old path *)
       else
         let () =
           (* Do not warn when overriding the default "-I ." path *)
           if not (DirPath.equal old_path Nameops.default_root_prefix) then
-            msg_warning
-              (str phys_path ++ strbrk " was previously bound to " ++
-                 pr_dirpath old_path ++ strbrk "; it is remapped to " ++
-                 pr_dirpath coq_path) in
+          warn_overriding_logical_loadpath (phys_path, old_path, coq_path)
+        in
         true in
     if replace then
       begin
@@ -84,10 +86,6 @@ let add_load_path phys_path coq_path ~implicit =
       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 filter_path f =
   let rec aux = function
   | [] -> []
@@ -97,18 +95,19 @@ let filter_path f =
   in
   aux !load_paths
 
-let expand_path dir =
+let expand_path ?root dir =
   let rec aux = function
   | [] -> []
-  | { path_physical = ph; path_logical = lg; path_implicit = implicit }  :: l ->
-    match implicit with
-    | true ->
-      (** The path is implicit, so that we only want match the logical suffix *)
-      if is_dirpath_suffix_of dir lg then (ph, lg) :: aux l else aux l
-    | false ->
-      (** Otherwise we must match exactly *)
-      if DirPath.equal dir lg then (ph, lg) :: aux l else aux l
-  in
+  | { path_physical = ph; path_logical = lg; path_implicit = implicit } :: l ->
+    let success =
+      match root with
+      | None ->
+        if implicit then is_dirpath_suffix_of dir lg
+        else DirPath.equal dir lg
+      | Some root ->
+        is_dirpath_prefix_of root lg &&
+          is_dirpath_suffix_of dir (drop_dirpath_prefix root lg) in
+    if success then (ph, lg) :: aux l else aux l in
   aux !load_paths
 
 let locate_file fname =
diff --git a/library/loadpath.mli b/library/loadpath.mli
index 49ffc114..4e79edbd 100644
--- a/library/loadpath.mli
+++ b/library/loadpath.mli
@@ -42,7 +42,7 @@ val find_load_path : CUnix.physical_path -> t
 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
+val expand_path : ?root:DirPath.t -> 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 matches of it. *)
 
diff --git a/library/nameops.ml b/library/nameops.ml
index 98b417c2..71405d02 100644
--- a/library/nameops.ml
+++ b/library/nameops.ml
@@ -12,7 +12,7 @@ open Names
 
 (* Identifiers *)
 
-let pr_id id = str (Id.to_string id)
+let pr_id id = Id.print id
 
 let pr_name = function
   | Anonymous -> str "_"
@@ -141,7 +141,7 @@ let name_max na1 na2 =
   | Name _ -> na1
   | Anonymous -> na2
 
-let pr_lab l = str (Label.to_string l)
+let pr_lab l = Label.print l
 
 let default_library = Names.DirPath.initial (* = ["Top"] *)
 
diff --git a/library/nametab.ml b/library/nametab.ml
index 40acb3ae..fa5db37e 100644
--- a/library/nametab.ml
+++ b/library/nametab.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Pp
 open Names
@@ -82,6 +82,14 @@ module Make (U : UserName) (E : EqualityType) : NAMETREE
 struct
   type elt = E.t
 
+  (* A name became inaccessible, even with absolute qualification.
+     Example:
+     Module F (X : S). Module X.
+     The argument X of the functor F is masked by the inner module X.
+   *)
+  let masking_absolute n =
+    Flags.if_verbose Feedback.msg_info (str ("Trying to mask the absolute name \"" ^ U.to_string n ^ "\"!"))
+
   type user_name = U.t
 
   type path_status =
@@ -119,9 +127,7 @@ struct
 	      | 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
+                masking_absolute n; tree.path
 	      | Nothing
 	      | Relative _ -> Relative (uname,o)
           else tree.path
@@ -144,7 +150,6 @@ struct
 	  | Nothing
 	  | Relative _ -> mktree (Absolute (uname,o)) tree.map
 
-
 let rec push_exactly uname o level tree = function
 | [] ->
   anomaly (Pp.str "Prefix longer than path! Impossible!")
@@ -155,9 +160,7 @@ let rec push_exactly uname o level tree = function
         | 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
+            masking_absolute n; tree.path
         | Nothing
         | Relative _ -> Relative (uname,o)
     in
@@ -523,9 +526,9 @@ let shortest_qualid_of_tactic kn =
     KnTab.shortest_qualid Id.Set.empty sp !the_tactictab
 
 let pr_global_env env ref =
-  try str (string_of_qualid (shortest_qualid_of_global env ref))
+  try pr_qualid (shortest_qualid_of_global env ref)
   with Not_found as e ->
-    if !Flags.debug then Pp.msg_debug (Pp.str "pr_global_env not found"); raise e
+    if !Flags.debug then Feedback.msg_debug (Pp.str "pr_global_env not found"); raise e
 
 let global_inductive r =
   match global r with
diff --git a/library/states.ml b/library/states.ml
index 2e1be764..95bd819d 100644
--- a/library/states.ml
+++ b/library/states.ml
@@ -35,7 +35,7 @@ let with_state_protection f x =
   try
     let a = f x in unfreeze st; a
   with reraise ->
-    let reraise = Errors.push reraise in
+    let reraise = CErrors.push reraise in
     (unfreeze st; iraise reraise)
 
 let with_state_protection_on_exception = Future.transactify
diff --git a/library/summary.ml b/library/summary.ml
index 46c52acc..6efa07f3 100644
--- a/library/summary.ml
+++ b/library/summary.ml
@@ -7,9 +7,11 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 
+module Dyn = Dyn.Make(struct end)
+
 type marshallable = [ `Yes | `No | `Shallow ]
 type 'a summary_declaration = {
   freeze_function : marshallable -> 'a;
@@ -21,7 +23,7 @@ let summaries = ref Int.Map.empty
 let mangle id = id ^ "-SUMMARY"
 
 let internal_declare_summary hash sumname sdecl =
-  let (infun, outfun) = Dyn.create (mangle sumname) in
+  let (infun, outfun) = Dyn.Easy.make_dyn (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
@@ -103,10 +105,10 @@ let unfreeze_summaries fs =
   in
   let fold id decl state =
     try fold id decl state
-    with e when Errors.noncritical e ->
-      let e = Errors.push e in
+    with e when CErrors.noncritical e ->
+      let e = CErrors.push e in
       Printf.eprintf "Error unfrezing summay %s\n%s\n%!"
-        (name_of_summary id) (Pp.string_of_ppcmds (Errors.iprint e));
+        (name_of_summary id) (Pp.string_of_ppcmds (CErrors.iprint e));
       iraise e
   in
   (** We rely on the order of the frozen list, and the order of folding *)
@@ -147,7 +149,7 @@ let unfreeze_summary datas =
       let (name, summary) = Int.Map.find id !summaries in
       try summary.unfreeze_function data
       with e ->
-        let e = Errors.push e in
+        let e = CErrors.push e in
         prerr_endline ("Exception unfreezing " ^ name);
         iraise e)
   datas
@@ -164,8 +166,15 @@ let project_summary { summaries; ml_module } ?(complement=false) ids =
   List.filter (fun (id, _) -> List.mem id ids) summaries
 
 let pointer_equal l1 l2 =
+  let ptr_equal d1 d2 =
+    let Dyn.Dyn (t1, x1) = d1 in
+    let Dyn.Dyn (t2, x2) = d2 in
+    match Dyn.eq t1 t2 with
+    | None -> false
+    | Some Refl -> x1 == x2
+    in
   CList.for_all2eq
-    (fun (id1,v1) (id2,v2) -> id1 = id2 && Dyn.pointer_equal v1 v2) l1 l2
+    (fun (id1,v1) (id2,v2) -> id1 = id2 && ptr_equal v1 v2) l1 l2
 
 (** All-in-one reference declaration + registration *)
 
@@ -176,3 +185,30 @@ let ref ?(freeze=fun _ r -> r) ~name x =
       unfreeze_function = ((:=) r);
       init_function = (fun () -> r := x) };
   r
+
+module Local = struct
+
+type 'a local_ref = ('a CEphemeron.key * string) ref
+
+let (:=) r v = r := (CEphemeron.create v, snd !r)
+
+let (!) r =
+  let key, name = !r in
+  try CEphemeron.get key
+  with CEphemeron.InvalidKey ->
+    let _, { init_function } =
+      Int.Map.find (String.hash (mangle name)) !summaries in
+    init_function ();
+    CEphemeron.get (fst !r)
+
+let ref ?(freeze=fun x -> x) ~name init =
+  let r = Pervasives.ref (CEphemeron.create init, name) in
+  declare_summary name
+    { freeze_function = (fun _ -> freeze !r);
+      unfreeze_function = ((:=) r);
+      init_function = (fun () -> r := init) };
+  r
+
+end
+
+let dump = Dyn.dump
diff --git a/library/summary.mli b/library/summary.mli
index c24a0b4b..1b57613c 100644
--- a/library/summary.mli
+++ b/library/summary.mli
@@ -42,6 +42,17 @@ val declare_summary : string -> 'a summary_declaration -> unit
 
 val ref : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref
 
+(* As [ref] but the value is local to a process, i.e. not sent to, say, proof
+ * workers.  It is useful to implement a local cache for example. *)
+module Local : sig
+
+  type 'a local_ref
+  val ref : ?freeze:('a -> 'a) -> name:string -> 'a -> 'a local_ref
+  val (:=) : 'a local_ref -> 'a -> unit
+  val (!) : 'a local_ref -> 'a
+
+end
+
 (** 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 *)
@@ -71,3 +82,7 @@ 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
+
+(** {6 Debug} *)
+
+val dump : unit -> (int * string) list
diff --git a/library/universes.ml b/library/universes.ml
index 7972c478..112b20a4 100644
--- a/library/universes.ml
+++ b/library/universes.ml
@@ -13,10 +13,11 @@ open Term
 open Environ
 open Univ
 open Globnames
+open Decl_kinds
 
 (** Global universe names *)
 type universe_names = 
-    Univ.universe_level Idmap.t * Id.t Univ.LMap.t
+  (polymorphic * Univ.universe_level) Idmap.t * Id.t Univ.LMap.t
 
 let global_universes =
   Summary.ref ~name:"Global universe names"
@@ -102,6 +103,7 @@ module Constraints = struct
 end
 
 type universe_constraints = Constraints.t
+type 'a constraint_accumulator = universe_constraints -> 'a -> 'a option
 type 'a universe_constrained = 'a * universe_constraints
 
 type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints
@@ -110,7 +112,7 @@ 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" ++
+      CErrors.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))
@@ -135,82 +137,76 @@ let to_constraints g s =
       | _, ULe, Some l' -> enforce_leq x y acc
       | _, ULub, _ -> acc
       | _, d, _ -> 
-	let f = if d == ULe then check_leq else check_eq in
+	let f = if d == ULe then UGraph.check_leq else UGraph.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
+let eq_constr_univs_infer univs fold m n accu =
+  if m == n then Some accu
   else 
-    let cstrs = ref Constraints.empty in
-    let eq_universes strict = Univ.Instance.check_eq univs in
+    let cstrs = ref accu in
+    let eq_universes strict = UGraph.check_eq_instances 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)
+	match fold (Constraints.singleton (u1, UEq, u2)) !cstrs with
+	| None -> false
+	| Some accu -> cstrs := accu; 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
+    if res then Some !cstrs else None
 
 (** Variant of [eq_constr_univs_infer] taking kind-of-term functions,
     to expose subterms of [m] and [n], arguments. *)
-let eq_constr_univs_infer_with kind1 kind2 univs m n =
+let eq_constr_univs_infer_with kind1 kind2 univs fold m n accu =
   (* spiwack: duplicates the code of [eq_constr_univs_infer] because I
      haven't find a way to factor the code without destroying
      pointer-equality optimisations in [eq_constr_univs_infer].
      Pointer equality is not sufficient to ensure equality up to
      [kind1,kind2], because [kind1] and [kind2] may be different,
      typically evaluating [m] and [n] in different evar maps. *)
-  let cstrs = ref Constraints.empty in
-  let eq_universes strict = Univ.Instance.check_eq univs in
+  let cstrs = ref accu in
+  let eq_universes strict = UGraph.check_eq_instances 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)
+      match fold (Constraints.singleton (u1, UEq, u2)) !cstrs with
+      | None -> false
+      | Some accu -> cstrs := accu; true
   in
   let rec eq_constr' m n = 
     Constr.compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq_constr' m n
   in
   let res = Constr.compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq_constr' m n in
-  res, !cstrs
+  if res then Some !cstrs else None
 
-let leq_constr_univs_infer univs m n =
-  if m == n then true, Constraints.empty
+let leq_constr_univs_infer univs fold m n accu =
+  if m == n then Some accu
   else 
-    let cstrs = ref Constraints.empty in
-    let eq_universes strict l l' = Univ.Instance.check_eq univs l l' in
+    let cstrs = ref accu in
+    let eq_universes strict l l' = UGraph.check_eq_instances 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)
+	match fold (Constraints.singleton (u1, UEq, u2)) !cstrs with
+	| None -> false
+	| Some accu -> cstrs := accu; 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
-	    ((if Univ.is_type0_univ u1 then
-		cstrs := Constraints.add (u1, ULe, u2) !cstrs);
-	     true)
-	  else
-	    (cstrs := Constraints.add (u1, ULe, u2) !cstrs; 
-	     true)
+	match fold (Constraints.singleton (u1, ULe, u2)) !cstrs with
+	| None -> false
+	| Some accu -> cstrs := accu; true
     in
     let rec eq_constr' m n = 
       m == n ||	Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n
@@ -220,7 +216,7 @@ let leq_constr_univs_infer univs m n =
 	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
+    if res then Some !cstrs else None
 
 let eq_constr_universes m n =
   if m == n then true, Constraints.empty
@@ -341,7 +337,7 @@ let existing_instance ctx 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"
+	CErrors.errorlabstrm "Universes"
 	  (str "Polymorphic constant expected " ++ int len2 ++ 
 	     str" levels but was given " ++ int len1)
       else ()
@@ -650,14 +646,14 @@ let normalize_univ_variable_opt_subst ectx =
   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
+    try ectx := Univ.LMap.add l (Some b) !ectx; b with Not_found -> assert false
   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
+    try subst := Univ.LMap.update l b !subst; b with Not_found -> assert false in
     normalize_univ_variable ~find ~update
 
 let normalize_universe_opt_subst subst =
@@ -706,12 +702,45 @@ let pr_universe_body = function
 
 let pr_universe_opt_subst = Univ.LMap.pr pr_universe_body
 
-exception Found of Level.t
+let compare_constraint_type d d' =
+  match d, d' with
+  | Eq, Eq -> 0
+  | Eq, _ -> -1
+  | _, Eq -> 1
+  | Le, Le -> 0
+  | Le, _ -> -1
+  | _, Le -> 1
+  | Lt, Lt -> 0
+
+type lowermap = constraint_type LMap.t
+
+let lower_union =
+  let merge k a b =
+    match a, b with
+    | Some _, None -> a
+    | None, Some _ -> b
+    | None, None -> None
+    | Some l, Some r ->
+       if compare_constraint_type l r >= 0 then a
+       else b
+  in LMap.merge merge
+
+let lower_add l c m =
+  try let c' = LMap.find l m in
+      if compare_constraint_type c c' > 0 then
+        LMap.add l c m
+      else m
+  with Not_found -> LMap.add l c m
+
+let lower_of_list l =
+  List.fold_left (fun acc (d,l) -> LMap.add l d acc) LMap.empty l
+
+exception Found of Level.t * lowermap
 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))
+  try LMap.iter (fun k (enf,alg,v',lower) ->
+    if not alg && enf && Universe.equal v' v then raise (Found (k, lower)))
 	insts; raise Not_found
-  with Found l -> l
+  with Found (f,l) -> (f,l)
 
 let compute_lbound left =
  (** The universe variable was not fixed yet.
@@ -730,27 +759,33 @@ let compute_lbound left =
 	 else None))
       None left
   
-let instantiate_with_lbound u lbound alg enforce (ctx, us, algs, insts, cstrs) =
+let instantiate_with_lbound u lbound lower 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)
+       LMap.add u (enforce,alg,lbound,lower) insts, cstrs'),
+      (enforce, alg, inst, lower)
   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)
+     LMap.add u (enforce,alg,lbound,lower) insts, cstrs),
+    (enforce, alg, lbound, lower)
 
 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)
+      prlist_with_sep spc (fun (d,r) -> pr_constraint_type d ++ Level.pr r) cstrs ++
+      fnl () ++ acc)
     cmap (mt ())
 
 let remove_alg l (ctx, us, algs, insts, cstrs) =
   (ctx, us, LSet.remove l algs, insts, cstrs)
+
+let remove_lower u lower =
+  let levels = Universe.levels u in
+  LSet.fold (fun l acc -> LMap.remove l acc) levels lower
     
 let minimize_univ_variables ctx us algs left right cstrs =
   let left, lbounds = 
@@ -760,22 +795,50 @@ let minimize_univ_variables ctx us algs left right cstrs =
 	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
+	  | Some lbound -> LMap.add r (true, false, lbound, lower_of_list lower)
+                                   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
-	       let l' = 
-		 if enf then Universe.make l 
-		 else l' 
-	       in acc', (d, l') :: left')
-	      (acc, []) l
-      with Not_found -> acc, []
+    let acc, left, lower =
+      try
+        let l = LMap.find u left in
+	let acc, left, newlow, lower =
+          List.fold_left
+	  (fun (acc, left', newlow, lower') (d, l) ->
+	   let acc', (enf,alg,l',lower) = aux acc l in
+	   let l' =
+	     if enf then Universe.make l
+	     else l'
+	   in acc', (d, l') :: left',
+              lower_add l d newlow, lower_union lower lower')
+	  (acc, [], LMap.empty, LMap.empty) l
+        in
+        let not_lower (d,l) =
+        (* We're checking if (d,l) is already implied by the lower
+	  constraints on some level u. If it represents l < u (d is Lt
+	  or d is Le and i > 0, the i < 0 case is impossible due to
+	  invariants of Univ), and the lower constraints only have l <=
+	  u then it is not implied. *)
+          Univ.Universe.exists
+          (fun (l,i) ->
+             let d =
+               if i == 0 then d
+               else match d with
+                    | Le -> Lt
+                    | d -> d
+             in
+             try let d' = LMap.find l lower in
+                 (* If d is stronger than the already implied lower
+                  * constraints we must keep it. *)
+                 compare_constraint_type d d' > 0
+             with Not_found ->
+               (** No constraint existing on l *) true) l
+        in
+        let left = List.uniquize (List.filter not_lower left) in
+        (acc, left, LMap.union newlow lower)
+      with Not_found -> acc, [], LMap.empty
     and right =
       try Some (LMap.find u right)
       with Not_found -> None
@@ -783,31 +846,33 @@ let minimize_univ_variables ctx us algs left right cstrs =
     let instantiate_lbound lbound =
       let alg = LSet.mem u algs in
 	if alg then
-	  (* u is algebraic: we instantiate it with it's lower bound, if any, 
+	  (* u is algebraic: we instantiate it with its lower bound, if any,
               or enforce the constraints if it is bounded from the top. *)
-	  instantiate_with_lbound u lbound true false acc
+          let lower = remove_lower lbound lower in
+	  instantiate_with_lbound u lbound lower 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. *)
+             let lower = LMap.remove l lower in
 	     if not (Level.equal l u) then
 	       (* Should check that u does not 
   	          have upper constraints that are not already in right *)
 	       let acc' = remove_alg l acc in
-		 instantiate_with_lbound u lbound false false acc'
-	     else 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
+		 instantiate_with_lbound u lbound lower false false acc'
+	     else acc, (true, false, lbound, lower)
+	  | None ->
+	     try
+	       (* Another universe represents the same lower bound,
+                  we can share them with no harm. *)
+	       let can, lower = find_inst insts lbound in
+               let lower = LMap.remove can lower in
+	       instantiate_with_lbound u (Universe.make can) lower false false acc
 	  with Not_found -> 
 	    (* We set u as the canonical universe representing lbound *)
-	    instantiate_with_lbound u lbound false true acc
+	    instantiate_with_lbound u lbound lower false true acc
     in
     let acc' acc = 
       match right with
@@ -816,7 +881,7 @@ let minimize_univ_variables ctx us algs left right 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 ((ctx', us, algs, insts, cstrs), (enf,_,inst,lower 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
@@ -828,15 +893,15 @@ let minimize_univ_variables ctx us algs left right cstrs =
 	    in
 	      (ctx', us, algs, insts, cstrs'), b
     in
-      if not (LSet.mem u ctx) then acc' (acc, (true, false, Universe.make u))
+      if not (LSet.mem u ctx) then acc' (acc, (true, false, Universe.make u, lower))
       else
 	let lbound = compute_lbound left in
 	  match lbound with
 	  | None -> (* Nothing to do *)
-	    acc' (acc, (true, false, Universe.make u))
+	    acc' (acc, (true, false, Universe.make u, lower))
 	  | Some lbound ->
 	     try acc' (instantiate_lbound lbound) 
-	     with Failure _ -> acc' (acc, (true, false, Universe.make u))
+	     with Failure _ -> acc' (acc, (true, false, Universe.make u, lower))
   and aux (ctx', us, algs, seen, cstrs as acc) u =
     try acc, LMap.find u seen 
     with Not_found -> instance acc u
@@ -869,27 +934,27 @@ let normalize_context_set ctx us algs =
   let csts = 
     (* We first put constraints in a normal-form: all self-loops are collapsed
        to equalities. *)
-    let g = Univ.LSet.fold (fun v g -> Univ.add_universe v false g)
-			   ctx Univ.empty_universes
+    let g = Univ.LSet.fold (fun v g -> UGraph.add_universe v false g)
+			   ctx UGraph.empty_universes
     in
     let g =
       Univ.Constraint.fold
 	(fun (l, d, r) g ->
 	 let g =
 	   if not (Level.is_small l || LSet.mem l ctx) then
-	     try Univ.add_universe l false g
-	     with Univ.AlreadyDeclared -> g
+	     try UGraph.add_universe l false g
+	     with UGraph.AlreadyDeclared -> g
 	   else g
 	 in
 	 let g =
 	   if not (Level.is_small r || LSet.mem r ctx) then
-	     try Univ.add_universe r false g
-	     with Univ.AlreadyDeclared -> g
+	     try UGraph.add_universe r false g
+	     with UGraph.AlreadyDeclared -> g
 	   else g
 	 in g) csts g
     in
-    let g = Univ.Constraint.fold Univ.enforce_constraint csts g in
-      Univ.constraints_of_universes g
+    let g = Univ.Constraint.fold UGraph.enforce_constraint csts g in
+      UGraph.constraints_of_universes g
   in
   let noneqs =
     Constraint.fold (fun (l,d,r as cstr) noneqs ->
@@ -930,9 +995,7 @@ let normalize_context_set ctx us algs =
      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 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
@@ -959,10 +1022,10 @@ 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
+      LSet.fold LSet.add (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
+      LSet.fold LSet.add (Universe.levels u) s
     | _ -> fold_constr aux s c
   in aux LSet.empty c
 
@@ -1027,7 +1090,7 @@ let refresh_constraints univs (ctx, cstrs) =
     Univ.Constraint.fold (fun c (cstrs', univs as acc) -> 
       let c = translate_cstr c in
       if is_trivial_leq c then acc
-      else (Univ.Constraint.add c cstrs', Univ.enforce_constraint c univs))
+      else (Univ.Constraint.add c cstrs', UGraph.enforce_constraint c univs))
       cstrs (Univ.Constraint.empty, univs)
   in ((ctx, cstrs'), univs')
 
@@ -1094,13 +1157,6 @@ let solve_constraints_system levels level_bounds level_min =
     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 when not (Univ.Level.is_small u) -> *)
-    (* 	 v.(i) <- univ_level_rem u v.(i) level_min.(i) *)
-    (*   | _ -> () *)
-    (* done *)
   done;
   v
diff --git a/library/universes.mli b/library/universes.mli
index edb06dfc..d3a271b8 100644
--- a/library/universes.mli
+++ b/library/universes.mli
@@ -19,7 +19,7 @@ val is_set_minimization : unit -> bool
 
 (** Global universe name <-> level mapping *)
 type universe_names = 
-  Univ.universe_level Idmap.t * Id.t Univ.LMap.t
+  (Decl_kinds.polymorphic * 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
@@ -63,6 +63,7 @@ module Constraints : sig
 end
 
 type universe_constraints = Constraints.t
+type 'a constraint_accumulator = universe_constraints -> 'a -> 'a option
 type 'a universe_constrained = 'a * universe_constraints
 type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints
 
@@ -71,11 +72,12 @@ val subst_univs_universe_constraints : universe_subst_fn ->
 
 val enforce_eq_instances_univs : bool -> universe_instance universe_constraint_function
 
-val to_constraints : universes -> universe_constraints -> constraints
+val to_constraints : UGraph.t -> 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
+val eq_constr_univs_infer : UGraph.t -> 'a constraint_accumulator ->
+  constr -> constr -> 'a -> 'a option
 
 (** [eq_constr_univs_infer_With kind1 kind2 univs m n] is a variant of
     {!eq_constr_univs_infer} taking kind-of-term functions, to expose
@@ -83,12 +85,13 @@ val eq_constr_univs_infer : Univ.universes -> constr -> constr -> bool universe_
 val eq_constr_univs_infer_with :
   (constr -> (constr,types) kind_of_term) ->
   (constr -> (constr,types) kind_of_term) ->
-  Univ.universes -> constr -> constr -> bool universe_constrained
+  UGraph.t -> 'a constraint_accumulator -> constr -> constr -> 'a -> 'a option
 
 (** [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
+val leq_constr_univs_infer : UGraph.t -> 'a constraint_accumulator ->
+  constr -> constr -> 'a -> 'a option
 
 (** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts,
     application grouping and the universe constraints in [c]. *)
@@ -223,46 +226,12 @@ val restrict_universe_context : universe_context_set -> universe_set -> universe
 val simplify_universe_context : universe_context_set -> 
   universe_context_set * universe_level_subst
 
-val refresh_constraints : universes -> universe_context_set -> universe_context_set * universes
+val refresh_constraints : UGraph.t -> universe_context_set -> universe_context_set * UGraph.t
 
 (** 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 ->
diff --git a/tactics/coretactics.ml4 b/ltac/coretactics.ml4
index 3efa65eb..61866675 100644
--- a/tactics/coretactics.ml4
+++ b/ltac/coretactics.ml4
@@ -13,15 +13,23 @@ open Names
 open Locus
 open Misctypes
 open Genredexpr
+open Constrarg
+open Extraargs
 
-open Proofview.Notations
+open Sigma.Notations
 
 DECLARE PLUGIN "coretactics"
 
+(** Basic tactics *)
+
 TACTIC EXTEND reflexivity
   [ "reflexivity" ] -> [ Tactics.intros_reflexivity ]
 END
 
+TACTIC EXTEND exact
+  [ "exact" casted_constr(c) ] -> [ Tactics.exact_no_check c ]
+END
+
 TACTIC EXTEND assumption
   [ "assumption" ] -> [ Tactics.assumption ]
 END
@@ -35,15 +43,15 @@ TACTIC EXTEND cut
 END
 
 TACTIC EXTEND exact_no_check
-  [ "exact_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.exact_no_check c) ]
+  [ "exact_no_check" constr(c) ] -> [ 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) ]
+  [ "vm_cast_no_check" constr(c) ] -> [ Tactics.vm_cast_no_check c ]
 END
 
 TACTIC EXTEND native_cast_no_check
-  [ "native_cast_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.native_cast_no_check c) ]
+  [ "native_cast_no_check" constr(c) ] -> [ Tactics.native_cast_no_check c ]
 END
 
 TACTIC EXTEND casetype
@@ -74,15 +82,13 @@ END
 
 TACTIC EXTEND left_with
   [ "left" "with" bindings(bl) ] -> [
-    let { Evd.sigma = sigma ; it = bl } = bl in
-    Tacticals.New.tclWITHHOLES false (Tactics.left_with_bindings false bl) sigma
+    Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> 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 bl) sigma
+    Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.left_with_bindings true bl)
   ]
 END
 
@@ -98,15 +104,13 @@ END
 
 TACTIC EXTEND right_with
   [ "right" "with" bindings(bl) ] -> [
-    let { Evd.sigma = sigma ; it = bl } = bl in
-    Tacticals.New.tclWITHHOLES false (Tactics.right_with_bindings false bl) sigma
+    Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> 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 bl) sigma
+    Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.right_with_bindings true bl)
   ]
 END
 
@@ -115,28 +119,22 @@ END
 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 = Tactics.constructor_tac false None i bl in
-    Tacticals.New.tclWITHHOLES false tac sigma
+    let tac bl = Tactics.constructor_tac false None i bl in
+    Tacticals.New.tclDELAYEDWITHHOLES false bl tac
   ]
 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 = Tactics.constructor_tac true None i bl in
-    Tacticals.New.tclWITHHOLES true tac sigma
+    let tac bl = Tactics.constructor_tac true None i bl in
+    Tacticals.New.tclDELAYEDWITHHOLES true bl tac
   ]
 END
 
@@ -144,9 +142,10 @@ END
 
 TACTIC EXTEND specialize
   [ "specialize" constr_with_bindings(c) ] -> [
-    let { Evd.sigma = sigma; it = c } = c in
-    let specialize = Proofview.V82.tactic (Tactics.specialize c) in
-    Tacticals.New.tclWITHHOLES false specialize sigma
+    Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> Tactics.specialize c None)
+  ]
+| [ "specialize" constr_with_bindings(c) "as" intropattern(ipat) ] -> [
+    Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> Tactics.specialize c (Some ipat))
   ]
 END
 
@@ -154,8 +153,20 @@ TACTIC EXTEND symmetry
   [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ]
 END
 
+TACTIC EXTEND symmetry_in
+| [ "symmetry" "in" in_clause(cl) ] -> [ Tactics.intros_symmetry cl ]
+END
+
 (** Split *)
 
+let rec delayed_list = function
+| [] -> { Tacexpr.delayed = fun _ sigma -> Sigma.here [] sigma }
+| x :: l ->
+  { Tacexpr.delayed = fun env sigma ->
+    let Sigma (x, sigma, p) = x.Tacexpr.delayed env sigma in
+    let Sigma (l, sigma, q) = (delayed_list l).Tacexpr.delayed env sigma in
+    Sigma (x :: l, sigma, p +> q) }
+
 TACTIC EXTEND split
   [ "split" ] -> [ Tactics.split_with_bindings false [NoBindings] ]
 END
@@ -166,15 +177,27 @@ END
 
 TACTIC EXTEND split_with
   [ "split" "with" bindings(bl) ] -> [
-    let { Evd.sigma = sigma ; it = bl } = bl in
-    Tacticals.New.tclWITHHOLES false (Tactics.split_with_bindings false [bl]) sigma
+    Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> 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 [bl]) sigma
+    Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.split_with_bindings true [bl])
+  ]
+END
+
+TACTIC EXTEND exists
+  [ "exists" ] -> [ Tactics.split_with_bindings false [NoBindings] ]
+| [ "exists" ne_bindings_list_sep(bll, ",") ] -> [
+    Tacticals.New.tclDELAYEDWITHHOLES false (delayed_list bll) (fun bll -> Tactics.split_with_bindings false bll)
+  ]
+END
+
+TACTIC EXTEND eexists
+  [ "eexists" ] -> [ Tactics.split_with_bindings true [NoBindings] ]
+| [ "eexists" ne_bindings_list_sep(bll, ",") ] -> [
+    Tacticals.New.tclDELAYEDWITHHOLES true (delayed_list bll) (fun bll -> Tactics.split_with_bindings true bll)
   ]
 END
 
@@ -184,6 +207,34 @@ TACTIC EXTEND intros_until
   [ "intros" "until" quantified_hypothesis(h) ] -> [ Tactics.intros_until h ]
 END
 
+TACTIC EXTEND intro
+| [ "intro" ] -> [ Tactics.intro_move None MoveLast ]
+| [ "intro" ident(id) ] -> [ Tactics.intro_move (Some id) MoveLast ]
+| [ "intro" ident(id) "at" "top" ] -> [ Tactics.intro_move (Some id) MoveFirst ]
+| [ "intro" ident(id) "at" "bottom" ] -> [ Tactics.intro_move (Some id) MoveLast ]
+| [ "intro" ident(id) "after" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveAfter h) ]
+| [ "intro" ident(id) "before" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveBefore h) ]
+| [ "intro" "at" "top" ] -> [ Tactics.intro_move None MoveFirst ]
+| [ "intro" "at" "bottom" ] -> [ Tactics.intro_move None MoveLast ]
+| [ "intro" "after" hyp(h) ] -> [ Tactics.intro_move None (MoveAfter h) ]
+| [ "intro" "before" hyp(h) ] -> [ Tactics.intro_move None (MoveBefore h) ]
+END
+
+(** Move *)
+
+TACTIC EXTEND move
+  [ "move" hyp(id) "at" "top" ] -> [ Tactics.move_hyp id MoveFirst ]
+| [ "move" hyp(id) "at" "bottom" ] -> [ Tactics.move_hyp id MoveLast ]
+| [ "move" hyp(id) "after" hyp(h) ] -> [ Tactics.move_hyp id (MoveAfter h) ]
+| [ "move" hyp(id) "before" hyp(h) ] -> [ Tactics.move_hyp id (MoveBefore h) ]
+END
+
+(** Rename *)
+
+TACTIC EXTEND rename
+| [ "rename" ne_rename_list_sep(ids, ",") ] -> [ Tactics.rename_hyp ids ]
+END
+
 (** Revert *)
 
 TACTIC EXTEND revert
@@ -200,12 +251,55 @@ TACTIC EXTEND simple_destruct
   [ "simple" "destruct" quantified_hypothesis(h) ] -> [ Tactics.simple_destruct h ]
 END
 
+(** Double induction *)
+
+TACTIC EXTEND double_induction
+  [ "double" "induction" quantified_hypothesis(h1) quantified_hypothesis(h2) ] ->
+  [ Elim.h_double_induction h1 h2 ]
+END
+
 (* Admit *)
 
 TACTIC EXTEND admit
  [ "admit" ] -> [ Proofview.give_up ]
 END
 
+(* Fix *)
+
+TACTIC EXTEND fix
+  [ "fix" natural(n) ] -> [ Tactics.fix None n ]
+| [ "fix" ident(id) natural(n) ] -> [ Tactics.fix (Some id) n ]
+END
+
+(* Cofix *)
+
+TACTIC EXTEND cofix
+  [ "cofix" ] -> [ Tactics.cofix None ]
+| [ "cofix" ident(id) ] -> [ Tactics.cofix (Some id) ]
+END
+
+(* Clear *)
+
+TACTIC EXTEND clear
+  [ "clear" hyp_list(ids) ] -> [
+    if List.is_empty ids then Tactics.keep []
+    else Tactics.clear ids
+  ]
+| [ "clear" "-" ne_hyp_list(ids) ] -> [ Tactics.keep ids ]
+END
+
+(* Clearbody *)
+
+TACTIC EXTEND clearbody
+  [ "clearbody" ne_hyp_list(ids) ] -> [ Tactics.clear_body ids ]
+END
+
+(* Generalize dependent *)
+
+TACTIC EXTEND generalize_dependent
+  [ "generalize" "dependent" constr(c) ] -> [ Tactics.generalize_dep c ]
+END
+
 (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *)
 
 open Tacexpr
@@ -222,11 +316,7 @@ let initial_atomic () =
         "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);
+        "intros", TacIntroPattern (false,[]);
       ]
   in
   let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in
diff --git a/tactics/evar_tactics.ml b/ltac/evar_tactics.ml
index 202aca0d..30aeba3b 100644
--- a/tactics/evar_tactics.ml
+++ b/ltac/evar_tactics.ml
@@ -7,13 +7,16 @@
 (************************************************************************)
 
 open Util
-open Errors
+open CErrors
 open Evar_refiner
 open Tacmach
 open Tacexpr
 open Refiner
 open Evd
 open Locus
+open Sigma.Notations
+open Proofview.Notations
+open Context.Named.Declaration
 
 (* The instantiate tactic *)
 
@@ -41,14 +44,14 @@ let instantiate_tac n c ido =
 	    match hloc with
 		InHyp ->
 		  (match decl with
-		      (_,None,typ) -> evar_list typ
+                    | LocalAssum (_,typ) -> evar_list typ
 		    | _ -> error
 			"Please be more specific: in type or value?")
 	      | InHypTypeOnly ->
-		  let (_, _, typ) = decl in evar_list typ
+		  evar_list (get_type decl)
 	      | InHypValueOnly ->
 		  (match decl with
-		      (_,Some body,_) -> evar_list body
+		    | LocalDef (_,body,_) -> evar_list body
 		    | _ -> error "Not a defined hypothesis.") in
   if List.length evl < n then
     error "Not enough uninstantiated existential variables.";
@@ -68,15 +71,21 @@ let instantiate_tac_by_name id c =
 
 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
+  Proofview.Goal.s_enter { s_enter = begin fun gl ->
+    let sigma = Tacmach.New.project gl in
     let env = Proofview.Goal.env gl in
+    let sigma = ref sigma in
+    let _ = Typing.e_sort_of env sigma typ in
+    let sigma = Sigma.Unsafe.of_evar_map !sigma in
     let id = match name with
     | Names.Anonymous -> 
       let id = Namegen.id_of_name_using_hdchar env typ name in
       Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env))
-    | Names.Name id -> id 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'))
+    | Names.Name id -> id
+    in
+    let Sigma (evar, sigma, p) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in
+    let tac =
       (Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere)
-  end
+    in
+    Sigma (tac, sigma, p)
+  end }
diff --git a/tactics/evar_tactics.mli b/ltac/evar_tactics.mli
index e67540c0..e67540c0 100644
--- a/tactics/evar_tactics.mli
+++ b/ltac/evar_tactics.mli
diff --git a/tactics/extraargs.ml4 b/ltac/extraargs.ml4
index 8f336cdb..0db1cd7b 100644
--- a/tactics/extraargs.ml4
+++ b/ltac/extraargs.ml4
@@ -10,13 +10,47 @@
 
 open Pp
 open Genarg
+open Stdarg
+open Constrarg
+open Pcoq.Prim
+open Pcoq.Constr
 open Names
+open Tacmach
 open Tacexpr
 open Taccoerce
 open Tacinterp
 open Misctypes
 open Locus
 
+(** Adding scopes for generic arguments not defined through ARGUMENT EXTEND *)
+
+let create_generic_quotation name e wit =
+  let inject (loc, v) = Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit) v) in
+  Tacentries.create_ltac_quotation name inject (e, None)
+
+let () = create_generic_quotation "integer" Pcoq.Prim.integer Stdarg.wit_int
+let () = create_generic_quotation "string" Pcoq.Prim.string Stdarg.wit_string
+
+let () = create_generic_quotation "ident" Pcoq.Prim.ident Constrarg.wit_ident
+let () = create_generic_quotation "reference" Pcoq.Prim.reference Constrarg.wit_ref
+let () = create_generic_quotation "uconstr" Pcoq.Constr.lconstr Constrarg.wit_uconstr
+let () = create_generic_quotation "constr" Pcoq.Constr.lconstr Constrarg.wit_constr
+let () = create_generic_quotation "ipattern" Pcoq.Tactic.simple_intropattern Constrarg.wit_intro_pattern
+let () = create_generic_quotation "open_constr" Pcoq.Constr.lconstr Constrarg.wit_open_constr
+let () =
+  let inject (loc, v) = Tacexpr.Tacexp v in
+  Tacentries.create_ltac_quotation "ltac" inject (Pcoq.Tactic.tactic_expr, Some 5)
+
+(** Backward-compatible tactic notation entry names *)
+
+let () =
+  let register name entry = Tacentries.register_tactic_notation_entry name entry in
+  register "hyp" wit_var;
+  register "simple_intropattern" wit_intro_pattern;
+  register "integer" wit_integer;
+  register "reference" wit_ref;
+  ()
+
 (* Rewriting orientation *)
 
 let _ = Metasyntax.add_token_obj "<-"
@@ -32,6 +66,14 @@ ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient
 | [ ] -> [ true ]
 END
 
+let pr_int _ _ _ i = Pp.int i
+
+let _natural = Pcoq.Prim.natural
+
+ARGUMENT EXTEND natural TYPED AS int PRINTED BY pr_int
+| [ _natural(i) ] -> [ i ]
+END
+
 let pr_orient = pr_orient () () ()
 
 
@@ -48,7 +90,7 @@ let occurrences_of = function
   | 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.";
+        CErrors.error "Illegal negative occurrence number.";
       OnlyOccurrences nl
 
 let coerce_to_int v = match Value.to_int v with
@@ -73,16 +115,14 @@ let glob_occs ist l = l
 let subst_occs evm l = l
 
 ARGUMENT EXTEND occurrences
+  TYPED AS int list
   PRINTED BY pr_int_list_full
 
   INTERPRETED BY interp_occs
   GLOBALIZED BY glob_occs
   SUBSTITUTED BY subst_occs
 
-  RAW_TYPED AS occurrences_or_var
   RAW_PRINTED BY pr_occurrences
-
-  GLOB_TYPED AS occurrences_or_var
   GLOB_PRINTED BY pr_occurrences
 
 | [ ne_integer_list(l) ] -> [ ArgArg l ]
@@ -99,6 +139,8 @@ let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t)
 
 let glob_glob = Tacintern.intern_constr
 
+let pr_lconstr _ prc _ c = prc c
+
 let subst_glob = Tacsubst.subst_glob_constr_and_expr
 
 ARGUMENT EXTEND glob
@@ -108,29 +150,42 @@ ARGUMENT EXTEND 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
   [ constr(c) ] -> [ c ]
 END
 
+let l_constr = Pcoq.Constr.lconstr
+
+ARGUMENT EXTEND lconstr
+    TYPED AS constr
+    PRINTED BY pr_lconstr
+  [ l_constr(c) ] -> [ c ]
+END
+
 ARGUMENT EXTEND lglob
+  TYPED AS glob
     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
 
+let interp_casted_constr ist gl c =
+  interp_constr_gen (Pretyping.OfType (pf_concl gl)) ist (pf_env gl) (project gl) c
+
+ARGUMENT EXTEND casted_constr
+  TYPED AS constr
+  PRINTED BY pr_gen
+  INTERPRETED BY interp_casted_constr
+  [ constr(c) ] -> [ c ]
+END
+
 type 'id gen_place= ('id * hyp_location_flag,unit) location
 
 type loc_place = Id.t Loc.located gen_place
@@ -166,9 +221,7 @@ ARGUMENT EXTEND hloc
     INTERPRETED BY interp_place
     GLOBALIZED BY intern_place
     SUBSTITUTED BY subst_place
-    RAW_TYPED AS loc_place
     RAW_PRINTED BY pr_loc_place
-    GLOB_TYPED AS loc_place
     GLOB_PRINTED BY pr_loc_place
   [ ] ->
     [ ConclLocation () ]
@@ -183,11 +236,13 @@ ARGUMENT EXTEND hloc
 
  END
 
+let pr_rename _ _ _ (n, m) = Nameops.pr_id n ++ str " into " ++ Nameops.pr_id m
 
-
-
-
-
+ARGUMENT EXTEND rename
+  TYPED AS ident * ident
+  PRINTED BY pr_rename
+| [ ident(n) "into" ident(m) ] -> [ (n, m) ]
+END
 
 (* Julien: Mise en commun des differentes version de replace with in by *)
 
@@ -205,6 +260,20 @@ END
 
 let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c
 
+let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Ppconstr.pr_lident cl
+let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl
+let in_clause' = Pcoq.Tactic.in_clause
+
+ARGUMENT EXTEND in_clause
+  TYPED AS clause_dft_concl
+  PRINTED BY pr_in_top_clause
+  RAW_TYPED AS clause_dft_concl
+  RAW_PRINTED BY pr_in_clause
+  GLOB_TYPED AS clause_dft_concl
+  GLOB_PRINTED BY pr_in_clause
+| [ in_clause'(cl) ] -> [ cl ]
+END
+
 (* spiwack: the print functions are incomplete, but I don't know what they are
 	used for *)
 let pr_r_nat_field natf =
@@ -237,7 +306,23 @@ let pr_r_int31_field i31f =
     | Retroknowledge.Int31PhiInv -> str "phi inv"
     | Retroknowledge.Int31Plus -> str "plus"
     | Retroknowledge.Int31Times -> str "times"
-    | _ -> assert false
+    | Retroknowledge.Int31Constructor -> assert false
+    | Retroknowledge.Int31PlusC -> str "plusc"
+    | Retroknowledge.Int31PlusCarryC -> str "pluscarryc"
+    | Retroknowledge.Int31Minus -> str "minus"
+    | Retroknowledge.Int31MinusC -> str "minusc"
+    | Retroknowledge.Int31MinusCarryC -> str "minuscarryc"
+    | Retroknowledge.Int31TimesC -> str "timesc"
+    | Retroknowledge.Int31Div21 -> str "div21"
+    | Retroknowledge.Int31Div -> str "div"
+    | Retroknowledge.Int31Diveucl -> str "diveucl"
+    | Retroknowledge.Int31AddMulDiv -> str "addmuldiv"
+    | Retroknowledge.Int31Compare -> str "compare"
+    | Retroknowledge.Int31Head0 -> str "head0"
+    | Retroknowledge.Int31Tail0 -> str "tail0"
+    | Retroknowledge.Int31Lor -> str "lor"
+    | Retroknowledge.Int31Land -> str "land"
+    | Retroknowledge.Int31Lxor -> str "lxor"
 
 let pr_retroknowledge_field f =
   match f with
@@ -245,7 +330,7 @@ let pr_retroknowledge_field f =
   | 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) ++
-                                           str "in " ++ str group
+                                           spc () ++ str "in " ++ qs group
 
 VERNAC ARGUMENT EXTEND retroknowledge_nat
 PRINTED BY pr_r_nat_field
diff --git a/tactics/extraargs.mli b/ltac/extraargs.mli
index 7c206d95..b12187e1 100644
--- a/tactics/extraargs.mli
+++ b/ltac/extraargs.mli
@@ -16,11 +16,15 @@ val wit_orient : bool Genarg.uniform_genarg_type
 val orient : bool Pcoq.Gram.entry
 val pr_orient : bool -> Pp.std_ppcmds
 
+val wit_rename : (Id.t * Id.t) Genarg.uniform_genarg_type
+
 val occurrences : (int list or_var) Pcoq.Gram.entry
 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_natural : int Genarg.uniform_genarg_type
+
 val wit_glob :
   (constr_expr,
   Tacexpr.glob_constr_and_expr,
@@ -31,6 +35,16 @@ val wit_lglob :
   Tacexpr.glob_constr_and_expr,
   Tacinterp.interp_sign * glob_constr) Genarg.genarg_type
 
+val wit_lconstr :
+  (constr_expr,
+  Tacexpr.glob_constr_and_expr,
+  Constr.t) Genarg.genarg_type
+
+val wit_casted_constr :
+  (constr_expr,
+  Tacexpr.glob_constr_and_expr,
+  Constr.t) Genarg.genarg_type
+
 val glob : constr_expr Pcoq.Gram.entry
 val lglob : constr_expr Pcoq.Gram.entry
 
@@ -47,14 +61,18 @@ val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry
 val wit_by_arg_tac :
   (raw_tactic_expr option,
   glob_tactic_expr option,
-  glob_tactic_expr option) Genarg.genarg_type
+  Geninterp.Val.t 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
 
-
 (** Spiwack: Primitive for retroknowledge registration *)
 
 val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry
 val wit_retroknowledge_field : (Retroknowledge.field, unit, unit) Genarg.genarg_type
+
+val wit_in_clause :
+  (Id.t Loc.located Locus.clause_expr,
+  Id.t Loc.located Locus.clause_expr,
+  Id.t Locus.clause_expr) Genarg.genarg_type
diff --git a/tactics/extratactics.ml4 b/ltac/extratactics.ml4
index 15613c7e..d88bcd7e 100644
--- a/tactics/extratactics.ml4
+++ b/ltac/extratactics.ml4
@@ -10,18 +10,24 @@
 
 open Pp
 open Genarg
+open Stdarg
+open Constrarg
 open Extraargs
+open Pcoq.Prim
+open Pcoq.Tactic
 open Mod_subst
 open Names
 open Tacexpr
 open Glob_ops
-open Tactics
-open Errors
+open CErrors
 open Util
 open Evd
+open Termops
 open Equality
 open Misctypes
+open Sigma.Notations
 open Proofview.Notations
+open Constrarg
 
 DECLARE PLUGIN "extratactics"
 
@@ -29,34 +35,44 @@ DECLARE PLUGIN "extratactics"
 (* replace, discriminate, injection, simplify_eq                      *)
 (* cutrewrite, dependent rewrite                                      *)
 
-let replace_in_clause_maybe_by (sigma1,c1) c2 cl  tac =
-  Tacticals.New.tclWITHHOLES false
-    (replace_in_clause_maybe_by c1 c2 cl (Option.map Tacinterp.eval_tactic tac))
-    sigma1
+let with_delayed_uconstr ist c tac =
+  let flags = {
+    Pretyping.use_typeclasses = false;
+    solve_unification_constraints = true;
+    use_hook = Some Pfedit.solve_by_implicit_tactic;
+    fail_evar = false;
+    expand_evars = true
+  } in
+  let c = Pretyping.type_uconstr ~flags ist c in
+  Tacticals.New.tclDELAYEDWITHHOLES false c tac
+
+let replace_in_clause_maybe_by ist c1 c2 cl tac =
+  with_delayed_uconstr ist c1
+  (fun c1 -> replace_in_clause_maybe_by c1 c2 cl (Option.map (Tacinterp.tactic_of_value ist) tac))
+
+let replace_term ist dir_opt c cl =
+  with_delayed_uconstr ist c (fun c -> replace_term dir_opt c cl)
 
-let replace_term dir_opt (sigma,c) cl =
-  Tacticals.New.tclWITHHOLES false
-    (replace_term dir_opt c cl)
-    sigma
+let clause = Pcoq.Tactic.clause_dft_concl
 
 TACTIC EXTEND replace
-   ["replace" open_constr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ]
--> [ replace_in_clause_maybe_by c1 c2 cl tac ]
+   ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ]
+-> [ replace_in_clause_maybe_by ist c1 c2 cl tac ]
 END
 
 TACTIC EXTEND replace_term_left
-  [ "replace"  "->" open_constr(c) clause(cl) ]
-  -> [ replace_term (Some true) c cl ]
+  [ "replace"  "->" uconstr(c) clause(cl) ]
+  -> [ replace_term ist (Some true) c cl ]
 END
 
 TACTIC EXTEND replace_term_right
-  [ "replace"  "<-" open_constr(c) clause(cl) ]
-  -> [ replace_term (Some false) c cl ]
+  [ "replace"  "<-" uconstr(c) clause(cl) ]
+  -> [ replace_term ist (Some false) c cl ]
 END
 
 TACTIC EXTEND replace_term
-  [ "replace" open_constr(c) clause(cl) ]
-  -> [ replace_term None c cl ]
+  [ "replace" uconstr(c) clause(cl) ]
+  -> [ replace_term ist None c cl ]
 END
 
 let induction_arg_of_quantified_hyp = function
@@ -67,99 +83,75 @@ let induction_arg_of_quantified_hyp = function
    ElimOnAnonHyp and not as a "constr", and "id" is interpreted as a
    ElimOnIdent and not as "constr" *)
 
+let mytclWithHoles tac with_evars c =
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let env = Tacmach.New.pf_env gl in
+    let sigma = Tacmach.New.project gl in
+    let sigma',c = Tactics.force_destruction_arg with_evars env sigma c in
+    Tacticals.New.tclWITHHOLES with_evars (tac with_evars (Some c)) sigma'
+  end }
+
 let elimOnConstrWithHoles tac with_evars c =
-  Tacticals.New.tclWITHHOLES with_evars
-    (tac with_evars (Some (None,ElimOnConstr c.it))) c.sigma
+  Tacticals.New.tclDELAYEDWITHHOLES with_evars c
+    (fun c -> tac with_evars (Some (None,ElimOnConstr c)))
 
-TACTIC EXTEND simplify_eq_main
-| [ "simplify_eq" constr_with_bindings(c) ] ->
-    [ elimOnConstrWithHoles dEq false c ]
-END
 TACTIC EXTEND simplify_eq
   [ "simplify_eq" ] -> [ dEq false None ]
-| [ "simplify_eq" quantified_hypothesis(h) ] ->
-    [ dEq false (Some (induction_arg_of_quantified_hyp h)) ]
-END
-TACTIC EXTEND esimplify_eq_main
-| [ "esimplify_eq" constr_with_bindings(c) ] ->
-    [ elimOnConstrWithHoles dEq true c ]
+| [ "simplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq false c ]
 END
 TACTIC EXTEND esimplify_eq
 | [ "esimplify_eq" ] -> [ dEq true None ]
-| [ "esimplify_eq" quantified_hypothesis(h) ] ->
-    [ dEq true (Some (induction_arg_of_quantified_hyp h)) ]
+| [ "esimplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq true c ]
 END
 
 let discr_main c = elimOnConstrWithHoles discr_tac false c
 
-TACTIC EXTEND discriminate_main
-| [ "discriminate" constr_with_bindings(c) ] ->
-    [ discr_main c ]
-END
 TACTIC EXTEND discriminate
 | [ "discriminate" ] -> [ discr_tac false None ]
-| [ "discriminate" quantified_hypothesis(h) ] ->
-    [ discr_tac false (Some (induction_arg_of_quantified_hyp h)) ]
-END
-TACTIC EXTEND ediscriminate_main
-| [ "ediscriminate" constr_with_bindings(c) ] ->
-    [ elimOnConstrWithHoles discr_tac true c ]
+| [ "discriminate" destruction_arg(c) ] ->
+    [ mytclWithHoles discr_tac false c ]
 END
 TACTIC EXTEND ediscriminate
 | [ "ediscriminate" ] -> [ discr_tac true None ]
-| [ "ediscriminate" quantified_hypothesis(h) ] ->
-    [ discr_tac true (Some (induction_arg_of_quantified_hyp h)) ]
+| [ "ediscriminate" destruction_arg(c) ] ->
+    [ mytclWithHoles discr_tac true c ]
 END
 
-open Proofview.Notations
 let discrHyp id =
   Proofview.tclEVARMAP >>= fun sigma ->
-  discr_main {it = Term.mkVar id,NoBindings; sigma = sigma;}
+  discr_main { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma }
 
-let injection_main c =
- elimOnConstrWithHoles (injClause None) false c
+let injection_main with_evars c =
+ elimOnConstrWithHoles (injClause None) with_evars c
 
-TACTIC EXTEND injection_main
-| [ "injection" constr_with_bindings(c) ] ->
-    [ injection_main c ]
-END
 TACTIC EXTEND injection
 | [ "injection" ] -> [ injClause None false None ]
-| [ "injection" quantified_hypothesis(h) ] ->
-    [ injClause None false (Some (induction_arg_of_quantified_hyp h)) ]
-END
-TACTIC EXTEND einjection_main
-| [ "einjection" constr_with_bindings(c) ] ->
-    [ elimOnConstrWithHoles (injClause None) true c ]
+| [ "injection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) false c ]
 END
 TACTIC EXTEND einjection
 | [ "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 (Some ipat)) false c ]
+| [ "einjection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) true c ]
 END
 TACTIC EXTEND injection_as
-| [ "injection" "as" simple_intropattern_list(ipat)] ->
+| [ "injection" "as" intropattern_list(ipat)] ->
     [ injClause (Some ipat) false None ]
-| [ "injection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] ->
-    [ 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 (Some ipat)) true c ]
+| [ "injection" destruction_arg(c) "as" intropattern_list(ipat)] ->
+    [ mytclWithHoles (injClause (Some ipat)) false c ]
 END
 TACTIC EXTEND einjection_as
-| [ "einjection" "as" simple_intropattern_list(ipat)] ->
+| [ "einjection" "as" intropattern_list(ipat)] ->
     [ injClause (Some ipat) true None ]
-| [ "einjection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] ->
-    [ injClause (Some ipat) true (Some (induction_arg_of_quantified_hyp h)) ]
+| [ "einjection" destruction_arg(c) "as" intropattern_list(ipat)] ->
+    [ mytclWithHoles (injClause (Some ipat)) true c ]
+END
+TACTIC EXTEND simple_injection
+| [ "simple" "injection" ] -> [ simpleInjClause false None ]
+| [ "simple" "injection" destruction_arg(c) ] -> [ mytclWithHoles simpleInjClause false c ]
 END
 
 let injHyp id =
   Proofview.tclEVARMAP >>= fun sigma ->
-  injection_main { it = Term.mkVar id,NoBindings; sigma = sigma; }
+  injection_main false { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma }
 
 TACTIC EXTEND dependent_rewrite
 | [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ]
@@ -199,7 +191,7 @@ END
 
 let onSomeWithHoles tac = function
   | None -> tac None
-  | Some c -> Tacticals.New.tclWITHHOLES false (tac (Some c.it)) c.sigma
+  | Some c -> Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> tac (Some c))
 
 TACTIC EXTEND contradiction
  [ "contradiction" constr_with_bindings_opt(c) ] ->
@@ -227,7 +219,7 @@ TACTIC EXTEND autorewrite
     [ auto_multi_rewrite  l ( cl) ]
 | [ "autorewrite" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] ->
     [
-      auto_multi_rewrite_with (Tacinterp.eval_tactic t) l cl
+      auto_multi_rewrite_with (Tacinterp.tactic_of_value ist t) l cl
     ]
 END
 
@@ -235,28 +227,28 @@ TACTIC EXTEND autorewrite_star
 | [ "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 ]
+  [ auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.tactic_of_value ist t) l cl ]
 END
 
 (**********************************************************************)
 (* Rewrite star                                                       *)
 
-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
-  Tacticals.New.tclWITHHOLES false
-    (general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true) sigma
+let rewrite_star ist clause orient occs c (tac : Geninterp.Val.t option) =
+  let tac' = Option.map (fun t -> Tacinterp.tactic_of_value ist t, FirstSolved) tac in
+  with_delayed_uconstr ist c
+    (fun c -> 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) ] ->
-    [ rewrite_star (Some id) o (occurrences_of occ) c tac ]
-| [ "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 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 Locus.AllOccurrences c tac ]
+| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] ->
+    [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ]
+| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] ->
+    [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ]
+| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) by_arg_tac(tac) ] ->
+    [ rewrite_star ist (Some id) o Locus.AllOccurrences c tac ]
+| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) by_arg_tac(tac) ] ->
+    [ rewrite_star ist None o (occurrences_of occ) c tac ]
+| [ "rewrite" "*" orient(o) uconstr(c) by_arg_tac(tac) ] ->
+    [ rewrite_star ist None o Locus.AllOccurrences c tac ]
     END
 
 (**********************************************************************)
@@ -269,11 +261,14 @@ let add_rewrite_hint bases ort t lcsr =
   let f ce = 
     let c, ctx = Constrintern.interp_constr env sigma ce in
     let ctx =
-      let ctx = Evd.evar_universe_context_set Univ.UContext.empty ctx in
+      let ctx = UState.context_set ctx in
         if poly then ctx
-	else (Global.push_context_set false ctx; Univ.ContextSet.empty)
+	else (** This is a global universe context that shouldn't be
+	       refreshed at every use of the hint, declare it globally. *)
+	  (Declare.declare_universe_context false ctx;
+           Univ.ContextSet.empty)
     in
-      Constrexpr_ops.constr_loc ce, (c, ctx), ort, t in
+      Constrexpr_ops.constr_loc ce, (c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t in
   let eqs = List.map f lcsr in
   let add_hints base = add_rew_rules base eqs in
   List.iter add_hints bases
@@ -313,7 +308,7 @@ let project_hint pri l2r r =
     | _ -> assert false in
   let p =
     if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in
-  let c = Reductionops.whd_beta Evd.empty (mkApp (c,Termops.extended_rel_vect 0 sign)) in
+  let c = Reductionops.whd_beta Evd.empty (mkApp (c, Context.Rel.to_extended_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
   let id =
@@ -321,7 +316,8 @@ let project_hint pri l2r r =
   in
   let ctx = Evd.universe_context_set sigma in
   let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in
-    (pri,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c))
+  let info = {Vernacexpr.hint_priority = pri; hint_pattern = None} in
+    (info,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c))
 
 let add_hints_iff l2r lc n bl =
   Hints.add_hints true bl
@@ -345,31 +341,52 @@ END
 (**********************************************************************)
 (* Refine                                                             *)
 
-let refine_tac simple {Glob_term.closure=closure;term=term} =
-  Proofview.Goal.nf_enter begin fun gl ->
+let constr_flags = {
+  Pretyping.use_typeclasses = true;
+  Pretyping.solve_unification_constraints = true;
+  Pretyping.use_hook = Some Pfedit.solve_by_implicit_tactic;
+  Pretyping.fail_evar = false;
+  Pretyping.expand_evars = true }
+
+let refine_tac ist simple with_classes c =
+  Proofview.Goal.nf_enter { 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
-    let refine = Proofview.Refine.refine ~unsafe:false update in
+    let flags =
+      { constr_flags with Pretyping.use_typeclasses = with_classes } in
+    let expected_type = Pretyping.OfType concl in
+    let c = Pretyping.type_uconstr ~flags ~expected_type ist c in
+    let update = { run = fun sigma -> c.delayed env sigma } in
+    let refine = Refine.refine ~unsafe:true update in
     if simple then refine
     else refine <*>
            Tactics.New.reduce_after_refine <*>
            Proofview.shelve_unifiable
-  end
+  end }
 
 TACTIC EXTEND refine
-| [ "refine" uconstr(c) ] -> [ refine_tac false c ]
+| [ "refine" uconstr(c) ] ->
+   [ refine_tac ist false true c ]
 END
 
 TACTIC EXTEND simple_refine
-| [ "simple" "refine" uconstr(c) ] -> [ refine_tac true c ]
+| [ "simple" "refine" uconstr(c) ] ->
+   [ refine_tac ist true true c ]
+END
+
+TACTIC EXTEND notcs_refine
+| [ "notypeclasses" "refine" uconstr(c) ] ->
+   [ refine_tac ist false false c ]
+END
+
+TACTIC EXTEND notcs_simple_refine
+| [ "simple" "notypeclasses" "refine" uconstr(c) ] ->
+   [ refine_tac ist true false c ]
+END
+
+(* Solve unification constraints using heuristics or fail if any remain *)
+TACTIC EXTEND solve_constraints
+[ "solve_constraints" ] -> [ Refine.solve_constraints ]
 END
 
 (**********************************************************************)
@@ -380,6 +397,12 @@ open Leminv
 
 let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater
 
+VERNAC ARGUMENT EXTEND sort
+| [ "Set" ] -> [ GSet ]
+| [ "Prop" ] -> [ GProp ]
+| [ "Type" ] -> [ GType [] ]
+END
+
 VERNAC COMMAND EXTEND DeriveInversionClear
 | [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ]
   => [ seff na ]
@@ -439,8 +462,6 @@ TACTIC EXTEND evar
 | [ "evar" constr(typ) ] -> [ let_evar Anonymous typ ]
 END
 
-open Tacticals
-
 TACTIC EXTEND instantiate
   [ "instantiate" "(" ident(id) ":=" lglob(c) ")" ] ->
     [ Tacticals.New.tclTHEN (instantiate_tac_by_name id c) Proofview.V82.nf_evar_goals ]
@@ -506,12 +527,12 @@ let add_transitivity_lemma left lem =
 (* Vernacular syntax *)
 
 TACTIC EXTEND stepl
-| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.eval_tactic tac) ]
+| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.tactic_of_value ist tac) ]
 | ["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) "by" tactic(tac) ] -> [ step false c (Tacinterp.tactic_of_value ist tac) ]
 | ["stepr" constr(c) ] -> [ step false c (Proofview.tclUNIT ()) ]
 END
 
@@ -525,11 +546,29 @@ VERNAC COMMAND EXTEND AddStepr CLASSIFIED AS SIDEFF
     [ add_transitivity_lemma false t ]
 END
 
+let cache_implicit_tactic (_,tac) = match tac with
+  | Some tac -> Pfedit.declare_implicit_tactic (Tacinterp.eval_tactic tac)
+  | None -> Pfedit.clear_implicit_tactic ()
+
+let subst_implicit_tactic (subst,tac) =
+  Option.map (Tacsubst.subst_tactic subst) tac
+
+let inImplicitTactic : glob_tactic_expr option -> obj =
+  declare_object {(default_object "IMPLICIT-TACTIC") with
+       open_function = (fun i o -> if Int.equal i 1 then cache_implicit_tactic o);
+       cache_function = cache_implicit_tactic;
+       subst_function = subst_implicit_tactic;
+       classify_function = (fun o -> Dispose)}
+
+let declare_implicit_tactic tac =
+  Lib.add_anonymous_leaf (inImplicitTactic (Some (Tacintern.glob_tactic tac)))
+
+let clear_implicit_tactic () =
+  Lib.add_anonymous_leaf (inImplicitTactic None)
+
 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 () ]
+| [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> [ declare_implicit_tactic tac ]
+| [ "Clear" "Implicit" "Tactic" ] -> [ clear_implicit_tactic () ]
 END
 
 
@@ -568,7 +607,7 @@ END
     during dependent induction. For internal use. *)
 
 TACTIC EXTEND specialize_eqs
-[ "specialize_eqs" hyp(id) ] -> [ Proofview.V82.tactic (specialize_eqs id) ]
+[ "specialize_eqs" hyp(id) ] -> [ specialize_eqs id ]
 END
 
 (**********************************************************************)
@@ -616,13 +655,10 @@ let subst_hole_with_term occ tc t =
 
 open Tacmach
 
-let out_arg = function
-  | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable")
-  | ArgArg x -> x
-
 let hResolve id c occ t =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
   let sigma = Proofview.Goal.sigma gl in
+  let sigma = Sigma.to_evar_map sigma 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
@@ -633,17 +669,18 @@ let hResolve id c occ t =
       Pretyping.understand env sigma t_hole
     with
       | Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _) as e ->
-          let (e, info) = Errors.push e in
+          let (e, info) = CErrors.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,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
-  Tacticals.New.tclTHEN
-    (Proofview.Unsafe.tclEVARS sigma)
+  let tac =
     (change_concl (mkLetIn (Anonymous,t_constr,t_constr_type,concl)))
-  end
+  in
+  Sigma.Unsafe.of_pair (tac, sigma)
+  end }
 
 let hResolve_auto id c t =
   let rec resolve_auto n = 
@@ -651,12 +688,12 @@ let hResolve_auto id c t =
       hResolve id c n t
     with
     | UserError _ as e -> raise e
-    | e when Errors.noncritical e -> resolve_auto (n+1)
+    | e when CErrors.noncritical e -> resolve_auto (n+1)
   in
   resolve_auto 1
 
 TACTIC EXTEND hresolve_core
-| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c (out_arg occ) t ]
+| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c occ t ]
 | [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> [ hResolve_auto id c t ]
 END
 
@@ -665,8 +702,8 @@ END
 *)
 
 let hget_evar n =
-  Proofview.Goal.nf_enter begin fun gl ->
-  let sigma = Proofview.Goal.sigma gl in
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
+  let sigma = Tacmach.New.project gl in
   let concl = Proofview.Goal.concl gl in
   let evl = evar_list concl in
   if List.length evl < n then
@@ -675,10 +712,10 @@ let hget_evar n =
   let ev = List.nth evl (n-1) in
   let ev_type = existential_type sigma ev in
   change_concl (mkLetIn (Anonymous,mkEvar ev,ev_type,concl))
-  end
+  end }
 
 TACTIC EXTEND hget_evar
-| [ "hget_evar" int_or_var(n) ] -> [ hget_evar (out_arg n) ]
+| [ "hget_evar" int_or_var(n) ] -> [ hget_evar n ]
 END
 
 (**********************************************************************)
@@ -694,12 +731,12 @@ END
 exception Found of unit Proofview.tactic
 
 let rewrite_except h =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { 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
+  end }
 
 
 let refl_equal = 
@@ -713,27 +750,28 @@ let refl_equal =
   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  : unit Proofview.tactic =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
     let type_of_a = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_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 ->
+         [Tactics.generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])];
+          Proofview.Goal.nf_enter { 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;
+            (** FIXME: this looks really wrong. Does anybody really use this tactic? *)
+            let Sigma (c, _, _) = (Tacred.pattern_occs [Locus.OnlyOccurrences [1], a]).Reductionops.e_redfun env (Sigma.Unsafe.of_evar_map Evd.empty) concl in
+	    change_concl c
+          end };
 	  simplest_case a]
-  end
+  end }
 
 
 let case_eq_intros_rewrite x =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let n = nb_prod (Proofview.Goal.concl gl) in
   (* Pp.msgnl (Printer.pr_lconstr x); *)
   Tacticals.New.tclTHENLIST [
       mkCaseEq x;
-    Proofview.Goal.nf_enter begin fun gl ->
+    Proofview.Goal.nf_enter { 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
@@ -742,16 +780,19 @@ let case_eq_intros_rewrite x =
                     Tacticals.New.tclDO (n'-n-1) intro;
 		    introduction h;
 		    rewrite_except h]
-    end
+    end }
   ]
-  end
+  end }
 
 let rec find_a_destructable_match t =
+  let cl = induction_arg_of_quantified_hyp (NamedHyp (Id.of_string "x")) in
+  let cl = [cl, (None, None), None], None in
+  let dest = TacAtom (Loc.ghost, TacInductionDestruct(false, false, cl)) in
   match kind_of_term t with
     | Case (_,_,x,_) when closed0 x ->
 	if isVar x then
 	  (* TODO check there is no rel n. *)
-	  raise (Found (Tacinterp.eval_tactic(<:tactic<destruct x>>)))
+	  raise (Found (Tacinterp.eval_tactic dest))
 	else
 	  (* let _ = Pp.msgnl (Printer.pr_lconstr x)  in *)
 	  raise (Found (case_eq_intros_rewrite x))
@@ -764,15 +805,15 @@ let destauto t =
   with Found tac -> tac
 
 let destauto_in id = 
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let ctype = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g (mkVar id)) gl in
 (*  Pp.msgnl (Printer.pr_lconstr (mkVar id)); *)
 (*  Pp.msgnl (Printer.pr_lconstr (ctype)); *)
   destauto ctype
-  end
+  end }
 
 TACTIC EXTEND destauto
-| [ "destauto" ] -> [ Proofview.Goal.nf_enter (fun gl -> destauto (Proofview.Goal.concl gl)) ]
+| [ "destauto" ] -> [ Proofview.Goal.nf_enter { enter = begin fun gl -> destauto (Proofview.Goal.concl gl) end } ]
 | [ "destauto" "in" hyp(id) ] -> [ destauto_in id ]
 END
 
@@ -780,10 +821,11 @@ END
 (* ********************************************************************* *)
 
 let eq_constr x y = 
-  Proofview.Goal.enter (fun gl ->
-    let evd = Proofview.Goal.sigma gl in
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let evd = Tacmach.New.project gl in
       if Evarutil.eq_constr_univs_test evd evd x y then Proofview.tclUNIT () 
-      else Tacticals.New.tclFAIL 0 (str "Not equal"))
+      else Tacticals.New.tclFAIL 0 (str "Not equal")
+  end }
 
 TACTIC EXTEND constr_eq
 | [ "constr_eq" constr(x) constr(y) ] -> [ eq_constr x y ]
@@ -796,9 +838,11 @@ END
 
 TACTIC EXTEND is_evar
 | [ "is_evar" constr(x) ] ->
-    [ match kind_of_term x with
+    [ Proofview.tclBIND Proofview.tclEVARMAP begin fun sigma ->
+      match Evarutil.kind_of_term_upto sigma x with
         | Evar _ -> Proofview.tclUNIT ()
         | _ -> Tacticals.New.tclFAIL 0 (str "Not an evar")
+      end
     ]
 END
 
@@ -849,13 +893,41 @@ TACTIC EXTEND is_cofix
     | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a cofix definition") ]
 END;;
 
+TACTIC EXTEND is_ind
+| [ "is_ind" constr(x) ] ->
+  [ match kind_of_term x with
+    | Ind _ -> Proofview.tclUNIT ()
+    | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not an (co)inductive datatype") ]
+END;;
+
+TACTIC EXTEND is_constructor
+| [ "is_constructor" constr(x) ] ->
+  [ match kind_of_term x with
+    | Construct _ -> Proofview.tclUNIT ()
+    | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constructor") ]
+END;;
+
+TACTIC EXTEND is_proj
+| [ "is_proj" constr(x) ] ->
+  [ match kind_of_term x with
+    | Proj _ -> Proofview.tclUNIT ()
+    | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a primitive projection") ]
+END;;
+
+TACTIC EXTEND is_const
+| [ "is_const" constr(x) ] ->
+  [ match kind_of_term x with
+    | Const _ -> Proofview.tclUNIT ()
+    | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constant") ]
+END;;
+
 (* Command to grab the evars left unresolved at the end of a proof. *)
 (* spiwack: I put it in extratactics because it is somewhat tied with
    the semantics of the LCF-style tactics, hence with the classic tactic
    mode. *)
 VERNAC COMMAND EXTEND GrabEvars
 [ "Grab" "Existential" "Variables" ]
-  => [ Vernacexpr.VtProofStep false, Vernacexpr.VtLater ]
+  => [ Vernac_classifier.classify_as_proofstep ]
   -> [ Proof_global.simple_with_current_proof (fun _ p  -> Proof.V82.grab_evars p) ]
 END
 
@@ -877,7 +949,7 @@ END
 TACTIC EXTEND unshelve
 | [ "unshelve" tactic1(t) ] ->
     [
-      Proofview.with_shelf (Tacinterp.eval_tactic t) >>= fun (gls, ()) ->
+      Proofview.with_shelf (Tacinterp.tactic_of_value ist t) >>= fun (gls, ()) ->
       Proofview.Unsafe.tclGETGOALS >>= fun ogls ->
       Proofview.Unsafe.tclSETGOALS (gls @ ogls)
     ]
@@ -886,7 +958,7 @@ END
 (* Command to add every unshelved variables to the focus *)
 VERNAC COMMAND EXTEND Unshelve
 [ "Unshelve" ]
-  => [ Vernacexpr.VtProofStep false, Vernacexpr.VtLater ]
+  => [ Vernac_classifier.classify_as_proofstep ]
   -> [ Proof_global.simple_with_current_proof (fun _ p  -> Proof.unshelve p) ]
 END
 
@@ -900,12 +972,12 @@ END
 
 (* cycles [n] goals *)
 TACTIC EXTEND cycle
-| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle (out_arg n) ]
+| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle 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) ]
+| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap i j ]
 END
 
 (* reverses the list of focused goals *)
@@ -913,7 +985,6 @@ TACTIC EXTEND revgoals
 | [ "revgoals" ] -> [ Proofview.revgoals ]
 END
 
-
 type cmp =
   | Eq
   | Lt | Le
@@ -922,10 +993,6 @@ type cmp =
 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"<"
@@ -948,7 +1015,7 @@ let pr_itest' _prc _prlc _prt = pr_itest
 
 
 
-ARGUMENT EXTEND comparison TYPED AS cmp PRINTED BY pr_cmp'
+ARGUMENT EXTEND comparison PRINTED BY pr_cmp'
 | [ "="  ] -> [ Eq ]
 | [ "<"  ] -> [ Lt ]
 | [ "<=" ] -> [ Le ]
@@ -964,9 +1031,7 @@ let interp_test ist gls = function
 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
@@ -994,14 +1059,14 @@ TACTIC EXTEND guard
 END
 
 let decompose l c =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { 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
+  end }
 
 TACTIC EXTEND decompose
 | [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> [ decompose l c ]
@@ -1020,7 +1085,7 @@ VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF
 END
 
 VERNAC COMMAND EXTEND Print_keys CLASSIFIED AS QUERY
-| [ "Print" "Equivalent" "Keys" ] -> [ msg_info (Keys.pr_keys Printer.pr_global) ]
+| [ "Print" "Equivalent" "Keys" ] -> [ Feedback.msg_info (Keys.pr_keys Printer.pr_global) ]
 END
 
 
diff --git a/tactics/extratactics.mli b/ltac/extratactics.mli
index e0e9f377..18334daf 100644
--- a/tactics/extratactics.mli
+++ b/ltac/extratactics.mli
@@ -11,4 +11,4 @@ val injHyp : Names.Id.t -> unit Proofview.tactic
 
 (* val refine_tac : Evd.open_constr -> unit Proofview.tactic *)
 
-val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Evd.sigma option -> unit Proofview.tactic
+val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Tacexpr.delayed_open option -> unit Proofview.tactic
diff --git a/ltac/g_auto.ml4 b/ltac/g_auto.ml4
new file mode 100644
index 00000000..6a8fa8d6
--- /dev/null
+++ b/ltac/g_auto.ml4
@@ -0,0 +1,228 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - 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 Pp
+open Genarg
+open Stdarg
+open Constrarg
+open Pcoq.Prim
+open Pcoq.Constr
+open Pcoq.Tactic
+open Tacexpr
+
+DECLARE PLUGIN "g_auto"
+
+(* Hint bases *)
+
+
+TACTIC EXTEND eassumption
+| [ "eassumption" ] -> [ Eauto.e_assumption ]
+END
+
+TACTIC EXTEND eexact
+| [ "eexact" constr(c) ] -> [ Eauto.e_give_exact c ]
+END
+
+let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases
+
+ARGUMENT EXTEND hintbases
+  TYPED AS preident_list_opt
+  PRINTED BY pr_hintbases
+| [ "with" "*" ] -> [ None ]
+| [ "with" ne_preident_list(l) ] -> [ Some l ]
+| [ ] -> [ Some [] ]
+END
+
+let eval_uconstrs ist cs =
+  let flags = {
+    Pretyping.use_typeclasses = false;
+    solve_unification_constraints = true;
+    use_hook = Some Pfedit.solve_by_implicit_tactic;
+    fail_evar = false;
+    expand_evars = true
+  } in
+  List.map (fun c -> Pretyping.type_uconstr ~flags ist c) cs
+
+let pr_auto_using_raw _ _ _  = Pptactic.pr_auto_using Ppconstr.pr_constr_expr
+let pr_auto_using_glob _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> Printer.pr_glob_constr c)
+let pr_auto_using _ _ _ = Pptactic.pr_auto_using Printer.pr_closed_glob
+
+ARGUMENT EXTEND auto_using
+  TYPED AS uconstr_list
+  PRINTED BY pr_auto_using
+  RAW_TYPED AS uconstr_list
+  RAW_PRINTED BY pr_auto_using_raw
+  GLOB_TYPED AS uconstr_list
+  GLOB_PRINTED BY pr_auto_using_glob
+| [ "using" ne_uconstr_list_sep(l, ",") ] -> [ l ]
+| [ ] -> [ [] ]
+END
+
+(** Auto *)
+
+TACTIC EXTEND trivial
+| [ "trivial" auto_using(lems) hintbases(db) ] ->
+    [ Auto.h_trivial (eval_uconstrs ist lems) db ]
+END
+
+TACTIC EXTEND info_trivial
+| [ "info_trivial" auto_using(lems) hintbases(db) ] ->
+    [ Auto.h_trivial ~debug:Info (eval_uconstrs ist lems) db ]
+END
+
+TACTIC EXTEND debug_trivial
+| [ "debug" "trivial" auto_using(lems) hintbases(db) ] ->
+    [ Auto.h_trivial ~debug:Debug (eval_uconstrs ist lems) db ]
+END
+
+TACTIC EXTEND auto
+| [ "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] ->
+    [ Auto.h_auto n (eval_uconstrs ist lems) db ]
+END
+
+TACTIC EXTEND info_auto
+| [ "info_auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] ->
+    [ Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db ]
+END
+
+TACTIC EXTEND debug_auto
+| [ "debug" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] ->
+    [ Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db ]
+END
+
+(** Eauto *)
+
+TACTIC EXTEND prolog
+| [ "prolog" "[" uconstr_list(l) "]" int_or_var(n) ] ->
+    [ Eauto.prolog_tac (eval_uconstrs ist l) n ]
+END
+
+let make_depth n = snd (Eauto.make_dimension n None)
+
+TACTIC EXTEND eauto
+| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
+    hintbases(db) ] ->
+    [ Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ]
+END
+
+TACTIC EXTEND new_eauto
+| [ "new" "auto" int_or_var_opt(n) auto_using(lems)
+    hintbases(db) ] ->
+    [ match db with
+      | None -> Auto.new_full_auto (make_depth n) (eval_uconstrs ist lems)
+      | Some l -> Auto.new_auto (make_depth n) (eval_uconstrs ist lems) l ]
+END
+
+TACTIC EXTEND debug_eauto
+| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
+    hintbases(db) ] ->
+    [ Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ]
+END
+
+TACTIC EXTEND info_eauto
+| [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
+    hintbases(db) ] ->
+    [ Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ]
+END
+
+TACTIC EXTEND dfs_eauto
+| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems)
+      hintbases(db) ] ->
+    [ Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db ]
+END
+
+TACTIC EXTEND autounfold
+| [ "autounfold" hintbases(db) clause_dft_concl(cl) ] -> [ Eauto.autounfold_tac db cl ]
+END
+
+TACTIC EXTEND autounfold_one
+| [ "autounfold_one" hintbases(db) "in" hyp(id) ] ->
+    [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, Locus.InHyp)) ]
+| [ "autounfold_one" hintbases(db) ] ->
+    [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ]
+      END
+
+TACTIC EXTEND autounfoldify
+| [ "autounfoldify" constr(x) ] -> [
+    let db = match Term.kind_of_term x with
+      | Term.Const (c,_) -> Names.Label.to_string (Names.con_label c)
+      | _ -> assert false
+    in Eauto.autounfold ["core";db] Locusops.onConcl 
+  ]
+END
+
+TACTIC EXTEND unify
+| ["unify" constr(x) constr(y) ] -> [ Tactics.unify x y ]
+| ["unify" constr(x) constr(y) "with" preident(base)  ] -> [
+    let table = try Some (Hints.searchtable_map base) with Not_found -> None in
+    match table with
+    | None ->
+      let msg = str "Hint table " ++ str base ++ str " not found" in
+      Tacticals.New.tclZEROMSG msg
+    | Some t ->
+      let state = Hints.Hint_db.transparent_state t in
+      Tactics.unify ~state x y
+  ]
+END
+
+
+TACTIC EXTEND convert_concl_no_check
+| ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x Term.DEFAULTcast ]
+END
+
+let pr_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_reference
+let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Printer.pr_global
+let glob_hints_path_atom ist = Hints.glob_hints_path_atom
+
+ARGUMENT EXTEND hints_path_atom
+  PRINTED BY pr_hints_path_atom
+
+  GLOBALIZED BY glob_hints_path_atom
+
+  RAW_PRINTED BY pr_pre_hints_path_atom
+  GLOB_PRINTED BY pr_hints_path_atom
+| [ ne_global_list(g) ] -> [ Hints.PathHints g ]
+| [ "_" ] -> [ Hints.PathAny ]
+END
+
+let pr_hints_path prc prx pry c = Hints.pp_hints_path c
+let pr_pre_hints_path prc prx pry c = Hints.pp_hints_path_gen Libnames.pr_reference c
+let glob_hints_path ist = Hints.glob_hints_path
+							      
+ARGUMENT EXTEND hints_path
+PRINTED BY pr_hints_path
+
+GLOBALIZED BY glob_hints_path
+RAW_PRINTED BY pr_pre_hints_path
+GLOB_PRINTED BY pr_hints_path
+
+| [ "(" hints_path(p) ")"  ] -> [ p ]
+| [ hints_path(p) "*" ] -> [ Hints.PathStar p ]
+| [ "emp" ] -> [ Hints.PathEmpty ]
+| [ "eps" ] -> [ Hints.PathEpsilon ]
+| [ hints_path(p) "|" hints_path(q) ] -> [ Hints.PathOr (p, q) ]
+| [ hints_path_atom(a) ] -> [ Hints.PathAtom a ]
+| [ hints_path(p) hints_path(q) ] -> [ Hints.PathSeq (p, q) ]
+END
+
+ARGUMENT EXTEND opthints
+  TYPED AS preident_list_opt
+  PRINTED BY pr_hintbases
+| [ ":" ne_preident_list(l) ] -> [ Some l ]
+| [ ] -> [ None ]
+END
+
+VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF
+| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [
+  let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in
+    Hints.add_hints (Locality.make_section_locality (Locality.LocalityFixme.consume ()))
+      (match dbnames with None -> ["core"] | Some l -> l) entry ]
+END
+
diff --git a/tactics/g_class.ml4 b/ltac/g_class.ml4
index e0c1f671..7e26b5d1 100644
--- a/tactics/g_class.ml4
+++ b/ltac/g_class.ml4
@@ -10,13 +10,12 @@
 
 open Misctypes
 open Class_tactics
+open Pcoq.Tactic
+open Stdarg
+open Constrarg
 
 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 =
@@ -45,26 +44,35 @@ ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug
 | [ ] -> [ false ]
 END
 
-let pr_depth _prc _prlc _prt = function
-    Some i -> Pp.int i
-  | None -> Pp.mt()
+let pr_search_strategy _prc _prlc _prt = function
+  | Some Dfs -> Pp.str "dfs"
+  | Some Bfs -> Pp.str "bfs"
+  | 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 ]
+ARGUMENT EXTEND eauto_search_strategy PRINTED BY pr_search_strategy
+| [ "(bfs)" ] -> [ Some Bfs ]
+| [ "(dfs)" ] -> [ Some Dfs ]
+| [ ] -> [ None ] 
 END
 
 (* true = All transparent, false = Opaque if possible *)
 
 VERNAC COMMAND EXTEND Typeclasses_Settings CLASSIFIED AS SIDEFF
- | [ "Typeclasses" "eauto" ":=" debug(d) depth(depth) ] -> [
+ | [ "Typeclasses" "eauto" ":=" debug(d) eauto_search_strategy(s) int_opt(depth) ] -> [
      set_typeclasses_debug d;
+     Option.iter set_typeclasses_strategy s;
      set_typeclasses_depth depth
    ]
 END
 
+(** Compatibility: typeclasses eauto has 8.5 and 8.6 modes *)
 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]) ]
+ | [ "typeclasses" "eauto" "bfs" int_or_var_opt(d) "with" ne_preident_list(l) ] ->
+    [ typeclasses_eauto ~strategy:Bfs ~depth:d l ]
+ | [ "typeclasses" "eauto" int_or_var_opt(d) "with" ne_preident_list(l) ] ->
+    [ typeclasses_eauto ~depth:d l ]
+ | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> [
+     typeclasses_eauto ~only_classes:true ~depth:d [Hints.typeclasses_db] ]
 END
 
 TACTIC EXTEND head_of_constr
@@ -82,3 +90,31 @@ END
 TACTIC EXTEND autoapply
   [ "autoapply" constr(c) "using" preident(i) ] -> [ Proofview.V82.tactic (autoapply c i) ]
 END
+
+(** TODO: DEPRECATE *)
+(* A progress test that allows to see if the evars have changed *)
+open Term
+open Proofview.Goal
+open Proofview.Notations
+
+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 { enter = begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
+    let check =
+      Proofview.Goal.nf_enter { enter = begin fun gl' ->
+        let newconcl = Proofview.Goal.concl gl' in
+        if eq_constr_mod_evars concl newconcl
+        then Tacticals.New.tclFAIL 0 (Pp.str"No progress made (modulo evars)")
+        else Proofview.tclUNIT ()
+      end }
+    in t <*> check
+  end }
+
+TACTIC EXTEND progress_evars
+  [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.tactic_of_value ist t) ]
+END
diff --git a/tactics/g_eqdecide.ml4 b/ltac/g_eqdecide.ml4
index 90565328..90565328 100644
--- a/tactics/g_eqdecide.ml4
+++ b/ltac/g_eqdecide.ml4
diff --git a/parsing/g_ltac.ml4 b/ltac/g_ltac.ml4
index 959b0e89..a3ca4ebc 100644
--- a/parsing/g_ltac.ml4
+++ b/ltac/g_ltac.ml4
@@ -6,6 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Util
 open Pp
 open Compat
 open Constrexpr
@@ -28,12 +31,54 @@ let arg_of_expr = function
 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
+let genarg_of_uconstr c = in_gen (rawwit Constrarg.wit_uconstr) c
+
+let reference_to_id = function
+  | Libnames.Ident (loc, id) -> (loc, id)
+  | Libnames.Qualid (loc,_) ->
+      CErrors.user_err_loc (loc, "",
+        str "This expression should be a simple identifier.")
+
+let tactic_mode = Gram.entry_create "vernac:tactic_command"
+
+let new_entry name =
+  let e = Gram.entry_create name in
+  e
+
+let toplevel_selector = new_entry "vernac:toplevel_selector"
+let tacdef_body = new_entry "tactic:tacdef_body"
+
+(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for
+    proof editing and changes nothing else). Then sets it as the default proof mode. *)
+let _ =
+  let mode = {
+    Proof_global.name = "Classic";
+    set = (fun () -> set_command_entry tactic_mode);
+    reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode);
+  } in
+  Proof_global.register_proof_mode mode
+
+(* Hack to parse "[ id" without dropping [ *)
+let test_bracket_ident =
+  Gram.Entry.of_parser "test_bracket_ident"
+    (fun strm ->
+      match get_tok (stream_nth 0 strm) with
+        | KEYWORD "[" ->
+            (match get_tok (stream_nth 1 strm) with
+              | IDENT _ -> ()
+	      | _ -> raise Stream.Failure)
+	| _ -> raise Stream.Failure)
 
 (* Tactics grammar rules *)
 
+let warn_deprecated_appcontext =
+  CWarnings.create ~name:"deprecated-appcontext" ~category:"deprecated"
+         (fun () -> strbrk "appcontext is deprecated and will be removed " ++
+                      strbrk "in a future version")
+
 GEXTEND Gram
   GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg
-          constr_may_eval constr_eval;
+          tactic_mode constr_may_eval constr_eval toplevel_selector;
 
   tactic_then_last:
     [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" ->
@@ -79,7 +124,8 @@ GEXTEND Gram
 (*To do: put Abstract in Refiner*)
       | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None)
       | IDENT "abstract"; tc = NEXT; "using";  s = ident ->
-          TacAbstract (tc,Some s) ]
+          TacAbstract (tc,Some s)
+      | sel = selector; ta = tactic_expr -> TacSelect (sel, ta) ]
 (*End of To do*)
     | "2" RIGHTA
       [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> TacOr (ta0,ta1)
@@ -105,10 +151,8 @@ GEXTEND Gram
       | 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))
-      | a = tactic_top_or_arg -> TacArg(!@loc,a)
-      | r = reference; la = LIST0 tactic_arg ->
+      | a = tactic_arg -> TacArg(!@loc,a)
+      | r = reference; la = LIST0 tactic_arg_compat ->
           TacArg(!@loc,TacCall (!@loc,r,la)) ]
     | "0"
       [ "("; a = tactic_expr; ")" -> a
@@ -132,23 +176,16 @@ GEXTEND Gram
           body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body)
       | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ]
   ;
-  (* Tactic arguments *)
-  tactic_arg:
-    [ [ "ltac:"; a = tactic_expr LEVEL "0" -> arg_of_expr a
-      | "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)
+  (* Tactic arguments to the right of an application *)
+  tactic_arg_compat:
+    [ [ a = tactic_arg -> a
+      | c = Constr.constr -> (match c with CRef (r,None) -> Reference r | c -> ConstrMayEval (ConstrTerm c))
+      (* Unambiguous entries: tolerated w/o "ltac:" modifier *)
       | "()" -> TacGeneric (genarg_of_unit ()) ] ]
   ;
   (* 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
+  tactic_arg:
+    [ [ c = constr_eval -> ConstrMayEval c
       | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l
       | IDENT "type_term"; c=uconstr -> TacPretype c
       | IDENT "numgoals" -> TacNumgoals ] ]
@@ -173,8 +210,7 @@ GEXTEND Gram
       | c = Constr.constr -> ConstrTerm c ] ]
   ;
   tactic_atom:
-    [ [ id = METAIDENT -> MetaIdArg (!@loc,true,id)
-      | n = integer -> TacGeneric (genarg_of_int n)
+    [ [ n = integer -> TacGeneric (genarg_of_int n)
       | r = reference -> TacCall (!@loc,r,[])
       | "()" -> TacGeneric (genarg_of_unit ()) ] ]
   ;
@@ -200,7 +236,7 @@ GEXTEND Gram
         Subterm (mode, oid, pc)
       | IDENT "appcontext";  oid = OPT Constr.ident;
           "["; pc = Constr.lconstr_pattern; "]" ->
-        msg_warning (strbrk "appcontext is deprecated");
+        warn_deprecated_appcontext ~loc:!@loc ();
         Subterm (true,oid, pc)
       | pc = Constr.lconstr_pattern -> Term pc ] ]
   ;
@@ -250,11 +286,216 @@ GEXTEND Gram
   (* Definitions for tactics *)
   tacdef_body:
     [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr ->
-	  (name, redef, TacFun (it, body))
+          if redef then Vernacexpr.TacticRedefinition (name, TacFun (it, body))
+          else
+            let id = reference_to_id name in
+            Vernacexpr.TacticDefinition (id, TacFun (it, body))
       | name = Constr.global; redef = ltac_def_kind; body = tactic_expr ->
-	  (name, redef, body) ] ]
+          if redef then Vernacexpr.TacticRedefinition (name, body)
+          else
+            let id = reference_to_id name in
+            Vernacexpr.TacticDefinition (id, body)
+    ] ]
   ;
   tactic:
     [ [ tac = tactic_expr -> tac ] ]
   ;
+
+  range_selector:
+    [ [ n = natural ; "-" ; m = natural -> (n, m)
+      | n = natural -> (n, n) ] ]
+  ;
+  (* We unfold a range selectors list once so that we can make a special case
+   * for a unique SelectNth selector. *)
+  range_selector_or_nth:
+    [ [ n = natural ; "-" ; m = natural;
+        l = OPT [","; l = LIST1 range_selector SEP "," -> l] ->
+          SelectList ((n, m) :: Option.default [] l)
+      | n = natural;
+        l = OPT [","; l = LIST1 range_selector SEP "," -> l] ->
+          Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l ] ]
+  ;
+  selector_body:
+  [ [ l = range_selector_or_nth -> l
+    | test_bracket_ident; "["; id = ident; "]" -> SelectId id ] ]
+  ;
+  selector:
+    [ [ IDENT "only"; sel = selector_body; ":" -> sel ] ]
+  ;
+  toplevel_selector:
+    [ [ sel = selector_body; ":" -> sel
+    |   IDENT "all"; ":" -> SelectAll ] ]
+  ;
+  tactic_mode:
+    [ [ g = OPT toplevel_selector; tac = G_vernac.subgoal_command -> tac g ] ]
+  ;
   END
+
+open Constrarg
+open Vernacexpr
+open Vernac_classifier
+open Goptions
+open Libnames
+
+let print_info_trace = ref None
+
+let _ = 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 =
+  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 | SelectList _ -> true | _ -> false in
+    let info = Option.append info !print_info_trace in
+    let (p,status) =
+      Pfedit.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 *)
+    let p = Proof.maximal_unfocus Vernacentries.command_focus p in
+    p,status) in
+    if not status then Feedback.feedback Feedback.AddedAxiom
+
+let pr_range_selector (i, j) =
+  if Int.equal i j then int i
+  else int i ++ str "-" ++ int j
+
+let pr_ltac_selector = function
+| SelectNth i -> int i ++ str ":"
+| SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++
+    str "]" ++ str ":"
+| SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":"
+| SelectAll -> str "all" ++ str ":"
+
+VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector
+| [ toplevel_selector(s) ] -> [ s ]
+END
+
+let pr_ltac_info n = str "Info" ++ spc () ++ int n
+
+VERNAC ARGUMENT EXTEND ltac_info PRINTED BY pr_ltac_info
+| [ "Info" natural(n) ] -> [ n ]
+END
+
+let pr_ltac_use_default b =
+  if b then (* Bug: a space is inserted before "..." *) str ".." else mt ()
+
+VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default
+| [ "." ] -> [ false ]
+| [ "..." ] -> [ true ]
+END
+
+let is_anonymous_abstract = function
+  | TacAbstract (_,None) -> true
+  | TacSolve [TacAbstract (_,None)] -> true
+  | _ -> false
+let rm_abstract = function
+  | TacAbstract (t,_) -> t
+  | TacSolve [TacAbstract (t,_)] -> TacSolve [t]
+  | x -> x
+let is_explicit_terminator = function TacSolve _ -> true | _ -> false
+
+VERNAC tactic_mode EXTEND VernacSolve
+| [ - ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] =>
+    [ classify_as_proofstep ] -> [
+    let g = Option.default (Proof_global.get_default_goal_selector ()) g in
+    vernac_solve g n t def
+  ]
+| [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] =>
+    [
+      let anon_abstracting_tac = is_anonymous_abstract t in
+      let solving_tac = is_explicit_terminator t in
+      let parallel = `Yes (solving_tac,anon_abstracting_tac) in
+      let pbr = if solving_tac then Some "par" else None in
+      VtProofStep{ parallel = parallel; proof_block_detection = pbr },
+      VtLater
+    ] -> [
+      let t = rm_abstract t in
+      vernac_solve SelectAll n t def
+    ]
+END
+
+let pr_ltac_tactic_level n = str "(at level " ++ int n ++ str ")"
+
+VERNAC ARGUMENT EXTEND ltac_tactic_level PRINTED BY pr_ltac_tactic_level
+| [ "(" "at" "level" natural(n) ")" ] -> [ n ]
+END
+
+VERNAC ARGUMENT EXTEND ltac_production_sep
+| [ "," string(sep) ] -> [ sep ]
+END
+
+let pr_ltac_production_item = function
+| Tacentries.TacTerm s -> quote (str s)
+| Tacentries.TacNonTerm (_, (arg, sep), id) ->
+  let sep = match sep with
+  | None -> mt ()
+  | Some sep -> str "," ++ spc () ++ quote (str sep)
+  in
+  str arg ++ str "(" ++ Nameops.pr_id id ++ sep ++ str ")"
+
+VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY pr_ltac_production_item
+| [ string(s) ] -> [ Tacentries.TacTerm s ]
+| [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] ->
+  [ Tacentries.TacNonTerm (loc, (Names.Id.to_string nt, sep), p) ]
+END
+
+VERNAC COMMAND EXTEND VernacTacticNotation
+| [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] =>
+  [ VtUnknown, VtNow ] ->
+  [
+    let l = Locality.LocalityFixme.consume () in
+    let n = Option.default 0 n in
+    Tacentries.add_tactic_notation (Locality.make_module_locality l) n r e
+  ]
+END
+
+VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY
+| [ "Print" "Ltac" reference(r) ] ->
+  [ Feedback.msg_notice (Tacintern.print_ltac (snd (Libnames.qualid_of_reference r))) ]
+END
+
+let pr_ltac_ref = Libnames.pr_reference
+
+let pr_tacdef_body tacdef_body =
+  let id, redef, body =
+    match tacdef_body with
+    | TacticDefinition ((_,id), body) -> Nameops.pr_id id, false, body
+    | TacticRedefinition (id, body) -> pr_ltac_ref id, true, body
+  in
+  let idl, body =
+    match body with
+      | Tacexpr.TacFun (idl,b) -> idl,b
+      | _ -> [], body in
+  id ++
+    prlist (function None -> str " _"
+      | Some id -> spc () ++ Nameops.pr_id id) idl
+  ++ (if redef then str" ::=" else str" :=") ++ brk(1,1)
+  ++ Pptactic.pr_raw_tactic body
+
+VERNAC ARGUMENT EXTEND ltac_tacdef_body
+PRINTED BY pr_tacdef_body
+| [ tacdef_body(t) ] -> [ t ]
+END
+
+VERNAC COMMAND EXTEND VernacDeclareTacticDefinition
+| [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => [
+    VtSideff (List.map (function
+      | TacticDefinition ((_,r),_) -> r
+      | TacticRedefinition (Ident (_,r),_) -> r
+      | TacticRedefinition (Qualid (_,q),_) -> snd(repr_qualid q)) l), VtLater
+  ] -> [
+    let lc = Locality.LocalityFixme.consume () in
+    Tacentries.register_ltac (Locality.make_module_locality lc) l
+  ]
+END
+
+VERNAC COMMAND EXTEND VernacPrintLtacs CLASSIFIED AS QUERY
+| [ "Print" "Ltac" "Signatures" ] -> [ Tacentries.print_ltacs () ]
+END
diff --git a/toplevel/g_obligations.ml4 b/ltac/g_obligations.ml4
index d620febb..987b9d53 100644
--- a/toplevel/g_obligations.ml4
+++ b/ltac/g_obligations.ml4
@@ -16,13 +16,25 @@
 open Libnames
 open Constrexpr
 open Constrexpr_ops
+open Stdarg
+open Constrarg
+open Extraargs
+
+let (set_default_tactic, get_default_tactic, print_default_tactic) = 
+  Tactic_option.declare_tactic_option "Program tactic"
+
+let () =
+  (** Delay to recover the tactic imperatively *)
+  let tac = Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () ->
+    snd (get_default_tactic ())
+  end in
+  Obligations.default_tactic := tac
 
 (* 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
@@ -32,9 +44,9 @@ let sigref = mkRefC (Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Init.Spec
 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"
+  Genarg.create_arg "withtac"
 
-let withtac = Pcoq.create_generic_entry "withtac" (Genarg.rawwit wit_withtac)
+let withtac = Pcoq.create_generic_entry Pcoq.utactic "withtac" (Genarg.rawwit wit_withtac)
 
 GEXTEND Gram
   GLOBAL: withtac;
@@ -57,11 +69,11 @@ 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" integer(num) "of" ident(name) ":" lglob(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" integer(num) ":" lglob(t) withtac(tac) ] ->
     [ obligation (num, None, Some t) tac ]
 | [ "Obligation" integer(num) withtac(tac) ] ->
     [ obligation (num, None, None) tac ]
@@ -109,7 +121,7 @@ open Pp
 
 VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY
 | [ "Show" "Obligation" "Tactic" ] -> [
-    msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ]
+    Feedback.msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ]
 END
 
 VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY
@@ -118,8 +130,8 @@ VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY
 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) ]
+| [ "Preterm" "of" ident(name) ] -> [ Feedback.msg_info (show_term (Some name)) ]
+| [ "Preterm" ] -> [ Feedback.msg_info (show_term None) ]
 END
 
 open Pp
diff --git a/tactics/g_rewrite.ml4 b/ltac/g_rewrite.ml4
index 72cfb01a..28078efd 100644
--- a/tactics/g_rewrite.ml4
+++ b/ltac/g_rewrite.ml4
@@ -20,6 +20,11 @@ open Extraargs
 open Tacmach
 open Tacticals
 open Rewrite
+open Stdarg
+open Constrarg
+open Pcoq.Prim
+open Pcoq.Constr
+open Pcoq.Tactic
 
 DECLARE PLUGIN "g_rewrite"
 
@@ -42,10 +47,7 @@ ARGUMENT EXTEND 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 ]
@@ -61,8 +63,17 @@ let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c
 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>"
+let pr_raw_strategy prc prlc _ (s : raw_strategy) =
+  let prr = Pptactic.pr_red_expr (prc, prlc, Pptactic.pr_or_by_notation Libnames.pr_reference, prc) in
+  Rewrite.pr_strategy prc prr s
+let pr_glob_strategy prc prlc _ (s : glob_strategy) =
+  let prr = Pptactic.pr_red_expr
+    (Ppconstr.pr_constr_expr,
+    Ppconstr.pr_lconstr_expr,
+    Pptactic.pr_or_by_notation Libnames.pr_reference,
+    Ppconstr.pr_constr_expr)
+  in
+  Rewrite.pr_strategy prc prr s
 
 ARGUMENT EXTEND rewstrategy
     PRINTED BY pr_strategy
@@ -71,10 +82,7 @@ ARGUMENT EXTEND rewstrategy
     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) ]
@@ -107,17 +115,11 @@ END
 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) ]
+| [ "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 =
@@ -126,7 +128,7 @@ let clsubstitute o c =
       (fun cl ->
         match cl with
           | Some id when is_tac id -> tclIDTAC
-          | _ -> cl_rewrite_clause c o AllOccurrences cl)
+          | _ -> Proofview.V82.of_tactic (cl_rewrite_clause c o AllOccurrences cl))
 
 TACTIC EXTEND substitute
 | [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ Proofview.V82.tactic (clsubstitute o c) ]
@@ -137,15 +139,15 @@ END
 
 TACTIC EXTEND setoid_rewrite
    [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ]
-   -> [ Proofview.V82.tactic (cl_rewrite_clause c o AllOccurrences None) ]
+   -> [ 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))]
+      [ 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)]
+      [ 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))]
+      [ 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))]
+      [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ]
 END
 
 VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF
@@ -184,9 +186,14 @@ END
 type binders_argtype = local_binder list
 
 let wit_binders =
- (Genarg.create_arg None "binders" : binders_argtype Genarg.uniform_genarg_type)
+ (Genarg.create_arg "binders" : binders_argtype Genarg.uniform_genarg_type)
 
-let binders = Pcoq.create_generic_entry "binders" (Genarg.rawwit wit_binders)
+let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wit_binders)
+
+let () =
+  let raw_printer _ _ _ l = Pp.pr_non_empty_arg Ppconstr.pr_binders l in
+  let printer _ _ _ _ = Pp.str "<Unavailable printer for binders>" in
+  Pptactic.declare_extra_genarg_pprule wit_binders raw_printer printer printer
 
 open Pcoq
 
@@ -261,3 +268,7 @@ TACTIC EXTEND setoid_transitivity
   [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ]
 | [ "setoid_etransitivity" ] -> [ setoid_transitivity None ]
 END
+
+VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY
+  [ "Print" "Rewrite" "HintDb" preident(s) ] -> [ Feedback.msg_notice (Autorewrite.print_rewrite_hintdb s) ]
+END
diff --git a/ltac/ltac.mllib b/ltac/ltac.mllib
new file mode 100644
index 00000000..fc51e48a
--- /dev/null
+++ b/ltac/ltac.mllib
@@ -0,0 +1,22 @@
+Taccoerce
+Tacsubst
+Tacenv
+Tactic_debug
+Tacintern
+Tacentries
+Profile_ltac
+Tacinterp
+Evar_tactics
+Tactic_option
+Extraargs
+G_obligations
+Coretactics
+Extratactics
+Profile_ltac_tactics
+G_auto
+G_class
+Rewrite
+G_rewrite
+Tauto
+G_eqdecide
+G_ltac
diff --git a/ltac/profile_ltac.ml b/ltac/profile_ltac.ml
new file mode 100644
index 00000000..2514eded
--- /dev/null
+++ b/ltac/profile_ltac.ml
@@ -0,0 +1,420 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Unicode
+open Pp
+open Printer
+open Util
+
+module M = CString.Map
+
+(** [is_profiling] and the profiling info ([stack]) should be synchronized with
+    the document; the rest of the ref cells are either local to individual
+    tactic invocations, or global flags, and need not be synchronized, since no
+    document-level backtracking happens within tactics. We synchronize
+    is_profiling via an option. *)
+let is_profiling = Flags.profile_ltac
+
+let set_profiling b = is_profiling := b
+let get_profiling () = !is_profiling
+
+(** LtacProf cannot yet handle backtracking into multi-success tactics.
+    To properly support this, we'd have to somehow recreate our location in the
+    call-stack, and stop/restart the intervening timers. This is tricky and
+    possibly expensive, so instead we currently just emit a warning that
+    profiling results will be off. *)
+let encountered_multi_success_backtracking = ref false
+
+let warn_profile_backtracking =
+  CWarnings.create ~name:"profile-backtracking" ~category:"ltac"
+    (fun () -> strbrk "Ltac Profiler cannot yet handle backtracking \
+       into multi-success tactics; profiling results may be wildly inaccurate.")
+
+let warn_encountered_multi_success_backtracking () =
+  if !encountered_multi_success_backtracking then
+    warn_profile_backtracking ()
+
+let encounter_multi_success_backtracking () =
+  if not !encountered_multi_success_backtracking
+  then begin
+    encountered_multi_success_backtracking := true;
+    warn_encountered_multi_success_backtracking ()
+  end
+
+
+(* *************** tree data structure for profiling ****************** *)
+
+type treenode = {
+  name : M.key;
+  total : float;
+  local : float;
+  ncalls : int;
+  max_total : float;
+  children : treenode M.t
+}
+
+let empty_treenode name = {
+  name;
+  total = 0.0;
+  local = 0.0;
+  ncalls = 0;
+  max_total = 0.0;
+  children = M.empty;
+}
+
+let root = "root"
+
+module Local = Summary.Local
+
+let stack = Local.ref ~name:"LtacProf-stack" [empty_treenode root]
+
+let reset_profile_tmp () =
+  Local.(stack := [empty_treenode root]);
+  encountered_multi_success_backtracking := false
+
+(* ************** XML Serialization  ********************* *)
+
+let rec of_ltacprof_tactic (name, t) =
+  assert (String.equal name t.name);
+  let open Xml_datatype in
+  let total = string_of_float t.total in
+  let local = string_of_float t.local in
+  let ncalls = string_of_int t.ncalls in
+  let max_total = string_of_float t.max_total in
+  let children = List.map of_ltacprof_tactic (M.bindings t.children) in
+  Element ("ltacprof_tactic",
+    [ ("name", name); ("total",total); ("local",local);
+      ("ncalls",ncalls); ("max_total",max_total)],
+    children)
+
+let of_ltacprof_results t =
+  let open Xml_datatype in
+  assert(String.equal t.name root);
+  let children = List.map of_ltacprof_tactic (M.bindings t.children) in
+  Element ("ltacprof", [("total_time", string_of_float t.total)], children)
+
+let rec to_ltacprof_tactic m xml =
+  let open Xml_datatype in
+  match xml with
+  | Element ("ltacprof_tactic",
+     [("name", name); ("total",total); ("local",local);
+      ("ncalls",ncalls); ("max_total",max_total)], xs) ->
+      let node = {
+         name;
+         total = float_of_string total;
+         local = float_of_string local;
+         ncalls = int_of_string ncalls;
+         max_total = float_of_string max_total;
+         children = List.fold_left to_ltacprof_tactic M.empty xs;
+       } in
+      M.add name node m
+  | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof_tactic XML")
+
+let to_ltacprof_results xml =
+  let open Xml_datatype in
+  match xml with
+  | Element ("ltacprof", [("total_time", t)], xs) ->
+     { name = root;
+       total = float_of_string t;
+       ncalls = 0;
+       max_total = 0.0;
+       local = 0.0;
+       children = List.fold_left to_ltacprof_tactic M.empty xs }
+  | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof XML")
+
+let feedback_results results =
+  Feedback.(feedback
+    (Custom (Loc.dummy_loc, "ltacprof_results", of_ltacprof_results results)))
+
+(* ************** pretty printing ************************************* *)
+
+let format_sec x = (Printf.sprintf "%.3fs" x)
+let format_ratio x = (Printf.sprintf "%.1f%%" (100. *. x))
+let padl n s = ws (max 0 (n - utf8_length s)) ++ str s
+let padr n s = str s ++ ws (max 0 (n - utf8_length s))
+let padr_with c n s =
+  let ulength = utf8_length s in
+  str (utf8_sub s 0 n) ++ str (String.make (max 0 (n - ulength)) c)
+
+let rec list_iter_is_last f = function
+  | []      -> []
+  | [x]     -> [f true x]
+  | x :: xs -> f false x :: list_iter_is_last f xs
+
+let header =
+  str " tactic                                   local  total   calls       max " ++
+  fnl () ++
+  str "────────────────────────────────────────┴──────┴──────┴───────┴─────────┘" ++
+  fnl ()
+
+let rec print_node ~filter all_total indent prefix (s, e) =
+  h 0 (
+    padr_with '-' 40 (prefix ^ s ^ " ")
+    ++ padl 7 (format_ratio (e.local /. all_total))
+    ++ padl 7 (format_ratio (e.total /. all_total))
+    ++ padl 8 (string_of_int e.ncalls)
+    ++ padl 10 (format_sec (e.max_total))
+  ) ++
+  fnl () ++
+  print_table ~filter all_total indent false e.children
+
+and print_table ~filter all_total indent first_level table =
+  let fold _ n l =
+    let s, total = n.name, n.total in
+    if filter s total then (s, n) :: l else l in
+  let ls = M.fold fold table [] in
+  match ls with
+  | [s, n] when not first_level ->
+     v 0 (print_node ~filter all_total indent (indent ^ "└") (s, n))
+  | _ ->
+    let ls =
+      List.sort (fun (_, { total = s1 }) (_, { total = s2}) ->
+                   compare s2 s1) ls in
+    let iter is_last =
+     let sep0 = if first_level then "" else if is_last then "  " else " │" in
+     let sep1 = if first_level then "─" else if is_last then " └─" else " ├─" in
+     print_node ~filter all_total (indent ^ sep0) (indent ^ sep1)
+    in
+    prlist (fun pr -> pr) (list_iter_is_last iter ls)
+
+let to_string ~filter ?(cutoff=0.0) node =
+  let tree = node.children in
+  let all_total = M.fold (fun _ { total } a -> total +. a) node.children 0.0 in
+  let flat_tree =
+    let global = ref M.empty in
+    let find_tactic tname l =
+      try M.find tname !global
+      with Not_found ->
+        let e = empty_treenode tname in
+        global := M.add tname e !global;
+        e in
+    let add_tactic tname stats = global := M.add tname stats !global in
+    let sum_stats add_total
+      { name; total = t1; local = l1; ncalls = n1; max_total = m1 }
+      {       total = t2; local = l2; ncalls = n2; max_total = m2 } = {
+          name;
+          total = if add_total then t1 +. t2 else t1;
+          local = l1 +. l2;
+          ncalls = n1 + n2;
+          max_total = if add_total then max m1 m2 else m1;
+          children = M.empty;
+      } in
+    let rec cumulate table =
+      let iter _ ({ name; children } as statistics) =
+        if filter name then begin
+          let stats' = find_tactic name global in
+          add_tactic name (sum_stats true stats' statistics);
+        end;
+        cumulate children
+      in
+      M.iter iter table
+    in
+    cumulate tree;
+    !global
+  in
+  warn_encountered_multi_success_backtracking ();
+  let filter s n = filter s && (all_total <= 0.0 || n /. all_total >= cutoff /. 100.0) in
+  let msg =
+    h 0 (str "total time: " ++ padl 11 (format_sec (all_total))) ++
+    fnl () ++
+    fnl () ++
+    header ++
+    print_table ~filter all_total "" true flat_tree ++
+    fnl () ++
+    header ++
+    print_table ~filter all_total "" true tree
+  in
+  msg
+
+(* ******************** profiling code ************************************** *)
+
+let get_child name node =
+  try M.find name node.children
+  with Not_found -> empty_treenode name
+
+let time () =
+  let times = Unix.times () in
+  times.Unix.tms_utime +. times.Unix.tms_stime
+
+let string_of_call ck =
+  let s =
+  string_of_ppcmds
+    (match ck with
+       | Tacexpr.LtacNotationCall s -> Pptactic.pr_alias_key s
+       | Tacexpr.LtacNameCall cst -> Pptactic.pr_ltac_constant cst
+       | Tacexpr.LtacVarCall (id, t) -> Nameops.pr_id id
+       | Tacexpr.LtacAtomCall te ->
+         (Pptactic.pr_glob_tactic (Global.env ())
+            (Tacexpr.TacAtom (Loc.ghost, te)))
+       | Tacexpr.LtacConstrInterp (c, _) ->
+         pr_glob_constr_env (Global.env ()) c
+       | Tacexpr.LtacMLCall te ->
+         (Pptactic.pr_glob_tactic (Global.env ())
+            te)
+    ) in
+  for i = 0 to String.length s - 1 do if s.[i] = '\n' then s.[i] <- ' ' done;
+  let s = try String.sub s 0 (CString.string_index_from s 0 "(*") with Not_found -> s in
+  CString.strip s
+
+let rec merge_sub_tree name tree acc =
+  try
+    let t = M.find name acc in
+    let t = {
+      name;
+      total = t.total +. tree.total;
+      ncalls = t.ncalls + tree.ncalls;
+      local = t.local +. tree.local;
+      max_total = max t.max_total tree.max_total;
+      children = M.fold merge_sub_tree tree.children t.children;
+    } in
+    M.add name t acc
+  with Not_found -> M.add name tree acc
+
+let merge_roots ?(disjoint=true) t1 t2 =
+  assert(String.equal t1.name t2.name);
+  { name = t1.name;
+    ncalls = t1.ncalls + t2.ncalls;
+    local = if disjoint then t1.local +. t2.local else t1.local;
+    total = if disjoint then t1.total +. t2.total else t1.total;
+    max_total = if disjoint then max t1.max_total t2.max_total else t1.max_total;
+    children =
+      M.fold merge_sub_tree t2.children t1.children }
+
+let rec find_in_stack what acc = function
+  | [] -> None
+  | { name } as x :: rest when String.equal name what -> Some(acc, x, rest)
+  | { name } as x :: rest -> find_in_stack what (x :: acc) rest
+
+let exit_tactic start_time c =
+  let diff = time () -. start_time in
+  match Local.(!stack) with
+  | [] | [_] ->
+    (* oops, our stack is invalid *)
+    encounter_multi_success_backtracking ();
+    reset_profile_tmp ()
+  | node :: (parent :: rest as full_stack) ->
+    let name = string_of_call c in
+    if not (String.equal name node.name) then
+      (* oops, our stack is invalid *)
+      encounter_multi_success_backtracking ();
+    let node = { node with
+      total = node.total +. diff;
+      local = node.local +. diff;
+      ncalls = node.ncalls + 1;
+      max_total = max node.max_total diff;
+    } in
+    (* updating the stack *)
+    let parent =
+      match find_in_stack node.name [] full_stack with
+      | None ->
+         (* no rec-call, we graft the subtree *)
+         let parent = { parent with
+           local = parent.local -. diff;
+           children = M.add node.name node parent.children } in
+         Local.(stack := parent :: rest);
+         parent
+      | Some(to_update, self, rest) ->
+         (* we coalesce the rec-call and update the lower stack *)
+         let self = merge_roots ~disjoint:false self node in
+         let updated_stack =
+           List.fold_left (fun s x ->
+             (try M.find x.name (List.hd s).children
+              with Not_found -> x) :: s) (self :: rest) to_update in
+         Local.(stack := updated_stack);
+         List.hd Local.(!stack)
+    in
+    (* Calls are over, we reset the stack and send back data *)
+    if rest == [] && get_profiling () then begin
+      assert(String.equal root parent.name);
+      reset_profile_tmp ();
+      feedback_results parent
+    end
+
+let tclFINALLY tac (finally : unit Proofview.tactic) =
+  let open Proofview.Notations in
+  Proofview.tclIFCATCH
+    tac
+    (fun v -> finally <*> Proofview.tclUNIT v)
+    (fun (exn, info) -> finally <*> Proofview.tclZERO ~info exn)
+
+let do_profile s call_trace tac =
+  let open Proofview.Notations in
+  Proofview.tclLIFT (Proofview.NonLogical.make (fun () ->
+  if !is_profiling then
+    match call_trace, Local.(!stack) with
+      | (_, c) :: _, parent :: rest ->
+        let name = string_of_call c in
+        let node = get_child name parent in
+        Local.(stack := node :: parent :: rest);
+        Some (time ())
+      | _ :: _, [] -> assert false
+      | _ -> None
+  else None)) >>= function
+  | Some start_time ->
+    tclFINALLY
+      tac
+      (Proofview.tclLIFT (Proofview.NonLogical.make (fun () ->
+        (match call_trace with
+        | (_, c) :: _ -> exit_tactic start_time c
+        | [] -> ()))))
+  | None -> tac
+
+(* ************** Accumulation of data from workers ************************* *)
+
+let get_local_profiling_results () = List.hd Local.(!stack)
+
+module SM = Map.Make(Stateid.Self)
+
+let data = ref SM.empty
+
+let _ =
+  Feedback.(add_feeder (function
+    | { id = State s; contents = Custom (_, "ltacprof_results", xml) } ->
+        let results = to_ltacprof_results xml in
+        let other_results = (* Multi success can cause this *)
+          try SM.find s !data
+          with Not_found -> empty_treenode root in
+        data := SM.add s (merge_roots results other_results) !data
+    | _ -> ()))
+
+let reset_profile () =
+  reset_profile_tmp ();
+  data := SM.empty
+
+(* ******************** *)
+
+let print_results_filter ~cutoff ~filter =
+  let valid id _ = Stm.state_of_id id <> `Expired in
+  data := SM.filter valid !data;
+  let results =
+    SM.fold (fun _ -> merge_roots ~disjoint:true) !data (empty_treenode root) in
+  let results = merge_roots results Local.(CList.last !stack) in
+  Feedback.msg_notice (to_string ~cutoff ~filter results)
+;;
+
+let print_results ~cutoff =
+  print_results_filter ~cutoff ~filter:(fun _ -> true)
+
+let print_results_tactic tactic =
+  print_results_filter ~cutoff:!Flags.profile_ltac_cutoff ~filter:(fun s ->
+    String.(equal tactic (sub (s ^ ".") 0 (min (1+length s) (length tactic)))))
+
+let do_print_results_at_close () =
+  if get_profiling () then print_results ~cutoff:!Flags.profile_ltac_cutoff
+
+let _ = Declaremods.append_end_library_hook do_print_results_at_close
+
+let _ =
+  let open Goptions in
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "Ltac Profiling";
+      optkey   = ["Ltac"; "Profiling"];
+      optread  = get_profiling;
+      optwrite = set_profiling }
diff --git a/ltac/profile_ltac.mli b/ltac/profile_ltac.mli
new file mode 100644
index 00000000..e5e2e419
--- /dev/null
+++ b/ltac/profile_ltac.mli
@@ -0,0 +1,48 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Ltac profiling primitives *)
+
+val do_profile :
+  string -> ('a * Tacexpr.ltac_call_kind) list ->
+    'b Proofview.tactic -> 'b Proofview.tactic
+
+val set_profiling : bool -> unit
+
+(* Cut off results < than specified cutoff *)
+val print_results : cutoff:float -> unit
+
+val print_results_tactic : string -> unit
+
+val reset_profile : unit -> unit
+
+val do_print_results_at_close : unit -> unit
+
+(* The collected statistics for a tactic. The timing data is collected over all
+ * instances of a given tactic from its parent. E.g. if tactic 'aaa' calls
+ * 'foo' twice, then 'aaa' will contain just one entry for 'foo' with the
+ * statistics of the two invocations combined, and also combined over all
+ * invocations of 'aaa'.
+ * total:     time spent running this tactic and its subtactics (seconds)
+ * local:      time spent running this tactic, minus its subtactics (seconds)
+ * ncalls: the number of invocations of this tactic that have been made
+ * max_total: the greatest running time of a single invocation (seconds)
+ *)
+type treenode = {
+  name : CString.Map.key;
+  total : float;
+  local : float;
+  ncalls : int;
+  max_total : float;
+  children : treenode CString.Map.t
+}
+
+(* Returns the profiling results known by the current process *)
+val get_local_profiling_results : unit -> treenode
+val feedback_results : treenode -> unit
+
diff --git a/ltac/profile_ltac_tactics.ml4 b/ltac/profile_ltac_tactics.ml4
new file mode 100644
index 00000000..8cb76d81
--- /dev/null
+++ b/ltac/profile_ltac_tactics.ml4
@@ -0,0 +1,40 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+(** Ltac profiling entrypoints *)
+
+open Profile_ltac
+open Stdarg
+
+DECLARE PLUGIN "profile_ltac_plugin"
+
+let tclSET_PROFILING b =
+   Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> set_profiling b))
+
+TACTIC EXTEND start_ltac_profiling
+| [ "start" "ltac" "profiling" ] -> [ tclSET_PROFILING true ]
+END
+
+TACTIC EXTEND stop_profiling
+| [ "stop" "ltac" "profiling" ] -> [ tclSET_PROFILING false ]
+END
+
+VERNAC COMMAND EXTEND ResetLtacProfiling CLASSIFIED AS SIDEFF
+  [ "Reset" "Ltac" "Profile" ] -> [ reset_profile() ]
+END
+
+VERNAC COMMAND EXTEND ShowLtacProfile CLASSIFIED AS QUERY
+| [ "Show" "Ltac" "Profile" ] -> [ print_results ~cutoff:!Flags.profile_ltac_cutoff ]
+| [ "Show" "Ltac" "Profile" "CutOff" int(n) ] -> [ print_results ~cutoff:(float_of_int n) ]
+END
+
+VERNAC COMMAND EXTEND ShowLtacProfileTactic CLASSIFIED AS QUERY
+  [ "Show" "Ltac" "Profile" string(s) ] -> [ print_results_tactic s ]
+END
diff --git a/tactics/rewrite.ml b/ltac/rewrite.ml
index 74bb6d59..44efdd38 100644
--- a/tactics/rewrite.ml
+++ b/ltac/rewrite.ml
@@ -6,18 +6,16 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "grammar/grammar.cma" i*)
-
 open Names
 open Pp
-open Errors
+open CErrors
 open Util
 open Nameops
 open Namegen
 open Term
 open Vars
 open Reduction
-open Tacticals
+open Tacticals.New
 open Tacmach
 open Tactics
 open Pretype_errors
@@ -34,6 +32,9 @@ open Elimschemes
 open Environ
 open Termops
 open Libnames
+open Sigma.Notations
+open Proofview.Notations
+open Context.Named.Declaration
 
 (** Typeclass-based generalized rewriting. *)
 
@@ -42,6 +43,10 @@ open Libnames
 let classes_dirpath =
   Names.DirPath.make (List.map Id.of_string ["Classes";"Coq"])
 
+let init_relation_classes () =
+  if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then ()
+  else Coqlib.check_required_library ["Coq";"Classes";"RelationClasses"]
+
 let init_setoid () =
   if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then ()
   else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"]
@@ -62,8 +67,10 @@ 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
+    fun (evd,cstrs) ->
+      let sigma = Sigma.Unsafe.of_evar_map evd in
+      let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force gr) in
+      let evd = Sigma.to_evar_map sigma in
 	(evd, cstrs), c
 
 (** Utility for dealing with polymorphic applications *)
@@ -84,7 +91,9 @@ 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 evd = Sigma.Unsafe.of_evar_map evd in
+  let Sigma (t, evd', _) = Evarutil.new_evar ~store:s env evd t in
+  let evd' = Sigma.to_evar_map evd' in
   let ev, _ = destEvar t in
     (evd', Evar.Set.add ev cstrs), t
 
@@ -101,7 +110,7 @@ let extends_undefined evars evars' =
 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
+  let t = Typing.e_solve_evars env evdref (mkApp (fc, args)) in
     (!evdref, cstrs), t
 
 let app_poly_nocheck env evars f args =
@@ -130,6 +139,7 @@ module GlobalBindings (M : sig
   val arrow : evars -> evars * constr
 end) = struct
   open M
+  open Context.Rel.Declaration
   let relation : evars -> evars * constr = find_global (fst relation) (snd relation)
 
   let reflexive_type = find_global relation_classes "Reflexive"
@@ -168,13 +178,17 @@ end) = struct
   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
+        let sigma = Sigma.Unsafe.of_evar_map evd in
+        let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in
+        let evd = Sigma.to_evar_map sigma 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
+        let sigma = Sigma.Unsafe.of_evar_map evd in
+        let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in
+        let evd = Sigma.to_evar_map sigma in
 	  (evd, cstrs), c
 
   let proper_proof env evars carrier relation x =
@@ -204,7 +218,7 @@ end) = struct
       | Some (x, Some rel) -> evars, rel
     in
     let rec aux env evars ty l =
-      let t = Reductionops.whd_betadeltaiota env (goalevars evars) ty in
+      let t = Reductionops.whd_all env (goalevars evars) ty in
 	match kind_of_term t, l with
 	| Prod (na, ty, b), obj :: cstrs ->
           let b = Reductionops.nf_betaiota (goalevars evars) b in
@@ -215,8 +229,8 @@ end) = struct
 	    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 
+	    let (evars, b, arg, cstrs) =
+	      aux (Environ.push_rel (LocalAssum (na, ty)) env) evars b cstrs
 	    in
 	    let ty = Reductionops.nf_betaiota (goalevars evars) ty in
 	    let pred = mkLambda (na, ty, b) in
@@ -307,14 +321,14 @@ end) = struct
     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
+	match kind_of_term (Reduction.whd_all 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
+	    let evars, rb = aux evars (Environ.push_rel (LocalAssum (na, ty)) env) b (pred n) in
 	      app_poly env evars forall_relation
 		[| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |]
 	| _ -> raise Not_found
@@ -325,7 +339,7 @@ end) = struct
 	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
+	  let ty = whd_all env ty in
 	  find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args
     in find env c ty args
 
@@ -343,13 +357,15 @@ end) = struct
 	  (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 sigma = Sigma.Unsafe.of_evar_map sigma in
+	   let Sigma ((evar, _), evars, _) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in
+	   let evars = Sigma.to_evar_map evars 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)
+	   with e when CErrors.noncritical e -> None)
   | _ -> None
 
 
@@ -403,7 +419,9 @@ module TypeGlobal = struct
 
 
   let inverse env (evd,cstrs) car rel = 
-    let evd, sort = Evarutil.new_Type ~rigid:Evd.univ_flexible env evd in
+    let sigma = Sigma.Unsafe.of_evar_map evd in
+    let Sigma (sort, sigma, _) = Evarutil.new_Type ~rigid:Evd.univ_flexible env sigma in
+    let evd = Sigma.to_evar_map sigma in
       app_poly_check env (evd,cstrs) coq_inverse [| car ; car; sort; rel |]
 
 end
@@ -420,15 +438,23 @@ let split_head = function
     hd :: tl -> hd, tl
   | [] -> assert(false)
 
+let eq_pb (ty, env, x, y as pb) (ty', env', x', y' as pb') =
+  pb == pb' || (ty == ty' && Constr.equal x x' && Constr.equal y y')
+
+let problem_inclusion x y =
+  List.for_all (fun pb -> List.exists (fun pb' -> eq_pb pb pb') y) x
+
 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
+       unsolvable constraints remain, so we check that this unification
+       does not introduce any new problem. *)
+    let _, pbs = Evd.extract_all_conv_pbs evd in
+    let evd' = Evarconv.the_conv_x env x y evd in
+    let _, pbs' = Evd.extract_all_conv_pbs evd' in
+    if evd' == evd || problem_inclusion pbs' pbs then Some evd'
+    else None
+  with e when CErrors.noncritical e -> None
 
 let convertible env evd x y =
   Reductionops.is_conv_leq env evd x y
@@ -446,6 +472,8 @@ type hypinfo = {
 let get_symmetric_proof b = 
   if b then PropGlobal.get_symmetric_proof else TypeGlobal.get_symmetric_proof
 
+let error_no_relation () = error "Cannot find a relation to rewrite."
+
 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
@@ -461,10 +489,18 @@ let rec decompose_app_rel env evd t =
   | 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 rel = mkApp (f, fargs) in
+    rel, args.(len - 2), args.(len - 1)
+  | _ -> error_no_relation ()
+
+let decompose_app_rel env evd t =
+  let (rel, t1, t2) = decompose_app_rel env evd t in
+  let ty = Retyping.get_type_of env evd rel in
+  let () = if not (Reduction.is_arity env ty) then error_no_relation () in
+  (rel, t1, t2)
 
 let decompose_applied_relation env sigma (c,l) =
+  let open Context.Rel.Declaration in
   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
@@ -487,7 +523,7 @@ let decompose_applied_relation env sigma (c,l) =
     | 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
+	match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> LocalAssum (n, t)) ctx)) with
 	| Some c -> c
 	| None -> error "Cannot find an homogeneous relation to rewrite."
 
@@ -553,9 +589,9 @@ let general_rewrite_unif_flags () =
   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.use_evars_eagerly_in_conv_on_closed_terms = true;
       Unification.modulo_delta = ts;
-      Unification.modulo_delta_types = ts;
+      Unification.modulo_delta_types = full_transparent_state;
       Unification.modulo_betaiota = true }
   in {
     Unification.core_unify_flags = core_flags;
@@ -584,7 +620,12 @@ let solve_remaining_by env sigma holes by =
     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 ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in
+    let solve_tac = match tac with
+    | Genarg.GenArg (Genarg.Glbwit tag, tac) ->
+      Ftactic.run (Geninterp.interp tag ist tac) (fun _ -> Proofview.tclUNIT ())
+    in
+    let solve_tac = tclCOMPLETE solve_tac in
     let solve sigma evk =
       let evi =
         try Some (Evd.find_undefined sigma evk)
@@ -762,9 +803,9 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) ev
 	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 [||]))
+	  (LocalDef (Id.of_string "do_subrelation",
+	             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
@@ -1015,7 +1056,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy =
 		      | x -> x
 		    in
 		    let res =
-		      { rew_car = prod_appvect r.rew_car args;
+		      { rew_car = Reductionops.hnf_prod_appvect env (goalevars evars) 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 
@@ -1106,8 +1147,9 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy =
       (* 	    | _ -> b') *)
 
       | Lambda (n, t, b) when flags.under_lambdas ->
-	let n' = name_app (fun id -> Tactics.fresh_id_in_env unfresh id env) n in
-	let env' = Environ.push_rel (n', None, t) env in
+        let n' = name_app (fun id -> Tactics.fresh_id_in_env unfresh id env) n in
+        let open Context.Rel.Declaration in
+	let env' = Environ.push_rel (LocalAssum (n', 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.strategy { state ; env = env' ; unfresh ;
@@ -1356,7 +1398,9 @@ module Strategies =
     let reduce (r : Redexpr.red_expr) : 'a pure_strategy = { strategy =
 	fun { state = state ; env = env ; term1 = t ; ty1 = ty ; cstr = cstr ; evars = evars } ->
           let rfn, ckind = Redexpr.reduction_of_red_expr env r in
-	  let evars', t' = rfn env (goalevars evars) t in
+          let sigma = Sigma.Unsafe.of_evar_map (goalevars evars) in
+	  let Sigma (t', sigma, _) = rfn.Reductionops.e_redfun env sigma t in
+	  let evars' = Sigma.to_evar_map sigma in
 	    if eq_constr t' t then
 	      state, Identity
 	    else
@@ -1371,7 +1415,7 @@ module Strategies =
 	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 ->
+	  with e when CErrors.noncritical e ->
             error "fold: the term is not unfoldable !"
 	in
 	  try
@@ -1380,7 +1424,7 @@ module Strategies =
 	      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
+	  with e when CErrors.noncritical e -> state, Fail
 					 }
   
 
@@ -1396,17 +1440,8 @@ let rewrite_with l2r flags c occs : strategy = { strategy =
   fun ({ state = () } as input) ->
     let unify env evars t =
       let (sigma, cstrs) = evars in
-      let ans =
-        try Some (refresh_hypinfo env sigma 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 rew
+      let (sigma, rew) = refresh_hypinfo env sigma c in
+      unify_eqn rew l2r flags env (sigma, cstrs) None t
     in
     let app = apply_rule unify occs in
     let strat = 
@@ -1430,7 +1465,7 @@ let solve_constraints env (evars,cstrs) =
       (Typeclasses.mark_resolvables ~filter evars)
       
 let nf_zeta =
-  Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+  Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA])
 
 exception RewriteFailure of Pp.std_ppcmds
 
@@ -1438,7 +1473,7 @@ 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 sort = Typing.e_sort_of env evdref concl in
   let evars = (!evdref, Evar.Set.empty) in
   let evars, cstr =
     let prop, (evars, arrow) = 
@@ -1491,31 +1526,34 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul
 (** Insert a declaration after the last declaration it depends on *)
 let rec insert_dependent env decl accu hyps = match hyps with
 | [] -> List.rev_append accu [decl]
-| (id, _, _  as ndecl) :: rem ->
-  if occur_var_in_decl env id decl then
+| ndecl :: rem ->
+  if occur_var_in_decl env (get_id ndecl) decl then
     List.rev_append accu (decl :: hyps)
   else
     insert_dependent env decl (ndecl :: accu) rem
 
 let assert_replacing id newt tac = 
-  let prf = Proofview.Goal.nf_enter begin fun gl ->
+  let prf = Proofview.Goal.nf_enter { enter = begin fun gl ->
     let concl = Proofview.Goal.concl gl in
     let env = Proofview.Goal.env gl in
     let ctx = Environ.named_context env in
-    let after, before = List.split_when (fun (n, b, t) -> Id.equal n id) ctx in
+    let after, before = List.split_when (Id.equal id % get_id) ctx in
     let nc = match before with
     | [] -> assert false
-    | (id, b, _) :: rem -> insert_dependent env (id, None, newt) [] after @ rem
+    | d :: rem -> insert_dependent env (LocalAssum (get_id d, newt)) [] after @ rem
     in
     let env' = Environ.reset_with_named_context (val_of_named_context nc) env in
-    Proofview.Refine.refine ~unsafe:false begin fun sigma ->
-      let sigma, ev = Evarutil.new_evar env' sigma concl in
-      let sigma, ev' = Evarutil.new_evar env sigma newt in
-      let map (n, _, _) = if Id.equal n id then ev' else mkVar n in
+    Refine.refine ~unsafe:false { run = begin fun sigma ->
+      let Sigma (ev, sigma, p) = Evarutil.new_evar env' sigma concl in
+      let Sigma (ev', sigma, q) = Evarutil.new_evar env sigma newt in
+      let map d =
+        let n = get_id d in
+        if Id.equal n id then ev' else mkVar n
+      in
       let (e, _) = destEvar ev in
-      sigma, mkEvar (e, Array.map_of_list map nc)
-    end
-  end in
+      Sigma (mkEvar (e, Array.map_of_list map nc), sigma, p +> q)
+    end }
+  end } in
   Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac)
 
 let newfail n s = 
@@ -1523,6 +1561,10 @@ let newfail n s =
 
 let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause =
   let open Proofview.Notations in
+  (** For compatibility *)
+  let beta_red _ sigma c = Reductionops.nf_betaiota sigma c in
+  let beta = Tactics.reduct_in_concl (beta_red, DEFAULTcast) in
+  let beta_hyp id = Tactics.reduct_in_hyp beta_red (id, InHyp) in
   let treat sigma res = 
     match res with
     | None -> newfail 0 (str "Nothing to rewrite")
@@ -1534,36 +1576,34 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause =
         let gls = List.rev (Evd.fold_undefined fold undef []) in
 	match clause, prf with
 	| Some id, Some p ->
-            let tac = Proofview.Refine.refine ~unsafe:false (fun h -> (h, p)) <*> Proofview.Unsafe.tclNEWGOALS gls in
+            let tac = tclTHENLIST [
+              Refine.refine ~unsafe:false { run = fun h -> Sigma.here p h };
+              Proofview.Unsafe.tclNEWGOALS gls;
+            ] in
             Proofview.Unsafe.tclEVARS undef <*>
-	    assert_replacing id newt tac
+	    tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id)
 	| Some id, None ->
             Proofview.Unsafe.tclEVARS undef <*>
-            convert_hyp_no_check (id, None, newt)
+            convert_hyp_no_check (LocalAssum (id, newt)) <*>
+            beta_hyp id
 	| None, Some p ->
             Proofview.Unsafe.tclEVARS undef <*>
-            Proofview.Goal.enter begin fun gl ->
+            Proofview.Goal.enter { 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
+            let make = { run = begin fun sigma ->
+              let Sigma (ev, sigma, q) = Evarutil.new_evar env sigma newt in
+              Sigma (mkApp (p, [| ev |]), sigma, q)
+            end } in
+            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 ->
+  Proofview.Goal.nf_enter { 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 sigma = Tacmach.New.project gl in
     let ty = match clause with
     | None -> concl
     | Some id -> Environ.named_type id env
@@ -1584,30 +1624,32 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause =
       let sigma = match origsigma with None -> sigma | Some sigma -> sigma in
       treat sigma res <*>
       (** For compatibility *)
-      beta <*> opt_beta <*> Proofview.shelve_unifiable
+      beta <*> Proofview.shelve_unifiable
     with
     | PretypeError (env, evd, (UnsatisfiableConstraints _ as e)) ->
       raise (RewriteFailure (Himsg.explain_pretype_error env evd e))
-  end
+  end }
 
 let tactic_init_setoid () = 
-  try init_setoid (); tclIDTAC
-  with e when Errors.noncritical e -> tclFAIL 0 (str"Setoid library not loaded")
+  try init_setoid (); Proofview.tclUNIT ()
+  with e when CErrors.noncritical e -> Tacticals.New.tclFAIL 0 (str"Setoid library not loaded")
 
 let cl_rewrite_clause_strat progress strat clause =
-  tclTHEN (tactic_init_setoid ())
-  ((if progress then tclWEAK_PROGRESS else fun x -> x)
-   (fun gl -> 
-    try Proofview.V82.of_tactic (cl_rewrite_clause_newtac ~progress strat clause) gl
-    with RewriteFailure e ->
-	 errorlabstrm "" (str"setoid rewrite failed: " ++ e)
+  tactic_init_setoid () <*>
+  (if progress then Proofview.tclPROGRESS else fun x -> x)
+   (Proofview.tclOR
+      (cl_rewrite_clause_newtac ~progress strat clause)
+      (fun (e, info) -> match e with
+       | RewriteFailure e ->
+	 tclZEROMSG (str"setoid rewrite failed: " ++ e)
        | Refiner.FailError (n, pp) -> 
-	  tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) gl))
+	  tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp)
+       | e -> Proofview.tclZERO ~info e))
 
 (** Setoid rewriting when called with "setoid_rewrite" *)
-let cl_rewrite_clause l left2right occs clause gl =
+let cl_rewrite_clause l left2right occs clause =
   let strat = rewrite_with left2right (general_rewrite_unif_flags ()) l occs in
-    cl_rewrite_clause_strat true strat clause gl
+    cl_rewrite_clause_strat true strat clause
 
 (** Setoid rewriting when called with "rewrite_strat" *)
 let cl_rewrite_clause_strat strat clause =
@@ -1658,6 +1700,40 @@ let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> (
   | StratEval r -> StratEval (g r)
   | StratFold c -> StratFold (f c)
 
+let pr_ustrategy = function
+| Subterms -> str "subterms"
+| Subterm -> str "subterm"
+| Innermost -> str "innermost"
+| Outermost -> str "outermost"
+| Bottomup -> str "bottomup"
+| Topdown -> str "topdown"
+| Progress -> str "progress"
+| Try -> str "try"
+| Any -> str "any"
+| Repeat -> str "repeat"
+
+let paren p = str "(" ++ p ++ str ")"
+
+let rec pr_strategy prc prr = function
+| StratId -> str "id"
+| StratFail -> str "fail"
+| StratRefl -> str "refl"
+| StratUnary (s, str) ->
+  pr_ustrategy s ++ spc () ++ paren (pr_strategy prc prr str)
+| StratBinary (Choice, str1, str2) ->
+  str "choice" ++ spc () ++ paren (pr_strategy prc prr str1) ++ spc () ++
+    paren (pr_strategy prc prr str2)
+| StratBinary (Compose, str1, str2) ->
+  pr_strategy prc prr str1 ++ str ";" ++ spc () ++ pr_strategy prc prr str2
+| StratConstr (c, true) -> prc c
+| StratConstr (c, false) -> str "<-" ++ spc () ++ prc c
+| StratTerms cl -> str "terms" ++ spc () ++ pr_sequence prc cl
+| StratHints (old, id) ->
+  let cmd = if old then "old_hints" else "hints" in
+  str cmd ++ spc () ++ str id
+| StratEval r -> str "eval" ++ spc () ++ prr r
+| StratFold c -> str "fold" ++ spc () ++ prc c
+
 let rec strategy_of_ast = function
   | StratId -> Strategies.id
   | StratFail -> Strategies.fail
@@ -1703,7 +1779,7 @@ let rec strategy_of_ast = function
 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,
+  (((Loc.ghost,Name n),None), Explicit,
   CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s),None),
 	   args))
 
@@ -1711,8 +1787,8 @@ 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
+    binders instance (Some (true, CRecord (Loc.ghost,fields)))
+    ~global ~generalize:false ~refine:false Hints.empty_hint_info
 
 let declare_instance_refl global binders a aeq n lemma =
   let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive"
@@ -1786,10 +1862,10 @@ let declare_projection n instance_id r =
   let poly = Global.is_polymorphic r in
   let env = Global.env () in
   let sigma = Evd.from_env env in
-  let evd,c = Evd.fresh_global env sigma r in
+  let sigma,c = Evd.fresh_global env sigma r in
   let ty = Retyping.get_type_of env sigma c in
   let term = proper_projection c ty in
-  let typ = Typing.unsafe_type_of env sigma term in
+  let sigma, typ = Typing.type_of env sigma term in
   let ctx, typ = decompose_prod_assum typ in
   let typ =
     let n =
@@ -1818,9 +1894,7 @@ let declare_projection n instance_id r =
     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 sigma = Evd.from_env env in
+let build_morphism_signature env sigma m =
   let m,ctx = Constrintern.interp_constr env sigma m in
   let sigma = Evd.from_ctx ctx in
   let t = Typing.unsafe_type_of env sigma m in
@@ -1845,8 +1919,10 @@ let build_morphism_signature m =
   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 evd = Evd.nf_constraints evd in
+  let m = Evarutil.nf_evars_universes evd morph in
+  Pretyping.check_evars env Evd.empty evd m;
+  Evd.evar_universe_context evd, m
 
 let default_morphism sign m =
   let env = Global.env () in
@@ -1883,16 +1959,17 @@ 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.from_env (Global.env ()) in
+  let env = Global.env () in
+  let evd = Evd.from_env env in
+  let uctx, instance = build_morphism_signature env evd m in
     if Lib.is_modtype () then
       let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id
 				(Entries.ParameterEntry 
-				 (None,poly,(instance,Univ.UContext.empty),None), 
+				 (None,poly,(instance,Evd.evar_context_universe_context uctx),None), 
 				 Decl_kinds.IsAssumption Decl_kinds.Logical)
       in
 	add_instance (Typeclasses.new_instance 
-			(Lazy.force PropGlobal.proper_class) None glob 
+			(Lazy.force PropGlobal.proper_class) Hints.empty_hint_info glob
 			poly (ConstRef cst));
 	declare_projection n instance_id (ConstRef cst)
     else
@@ -1903,7 +1980,7 @@ let add_morphism_infer glob m n =
       let hook _ = function
 	| Globnames.ConstRef cst ->
 	  add_instance (Typeclasses.new_instance 
-			  (Lazy.force PropGlobal.proper_class) None
+			  (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info
 			  glob poly (ConstRef cst));
 	  declare_projection n instance_id (ConstRef cst)
 	| _ -> assert false
@@ -1911,7 +1988,7 @@ let add_morphism_infer glob m n =
       let hook = Lemmas.mk_hook hook in
 	Flags.silently
 	  (fun () ->
-	    Lemmas.start_proof instance_id kind evd instance hook;
+	    Lemmas.start_proof instance_id kind (Evd.from_ctx uctx) instance hook;
 	    ignore (Pfedit.by (Tacinterp.interp tac))) ()
 
 let add_morphism glob binders m s n =
@@ -1919,15 +1996,15 @@ let add_morphism glob binders m s n =
   let poly = Flags.is_universe_polymorphism () in
   let instance_id = add_suffix n "_Proper" in
   let instance =
-    ((Loc.ghost,Name instance_id), Explicit,
+    (((Loc.ghost,Name instance_id),None), 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)
+	     (Some (true, CRecord (Loc.ghost,[])))
+	      ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info)
 
 (** Bind to "rewrite" too *)
 
@@ -1986,12 +2063,12 @@ let unification_rewrite l2r c1 c2 sigma prf car rel but env =
   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 evars = Tacmach.New.project gl in
+  let env = Tacmach.New.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)
+    | Some id -> Tacmach.New.pf_get_hyp_typ id gl
+    | None -> Evarutil.nf_evar evars (Tacmach.New.pf_concl gl)
   in
   unification_rewrite l2r hi.c1 hi.c2 sigma hi.prf hi.car hi.rel but env
 
@@ -2001,7 +2078,8 @@ let general_rewrite_flags = { under_lambdas = false; on_morphisms = true }
 (* 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 general_s_rewrite cl l2r occs (c,l) ~new_goals =
+  Proofview.Goal.nf_enter { enter = begin fun 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
@@ -2012,45 +2090,41 @@ let general_s_rewrite cl l2r occs (c,l) ~new_goals gl =
     (), res
 	      }
   in
-  let origsigma = project gl in
-  init_setoid ();
-    try
-      tclWEAK_PROGRESS 
+  let origsigma = Tacmach.New.project gl in
+  tactic_init_setoid () <*>
+    Proofview.tclOR
+      (tclPROGRESS
 	(tclTHEN
-           (Refiner.tclEVARS evd)
-	   (Proofview.V82.of_tactic
-	    (cl_rewrite_clause_newtac ~progress:true ~abs:(Some abs) ~origsigma strat cl))) gl
-    with RewriteFailure e ->
-      tclFAIL 0 (str"setoid rewrite failed: " ++ e) gl
+           (Proofview.Unsafe.tclEVARS evd)
+	    (cl_rewrite_clause_newtac ~progress:true ~abs:(Some abs) ~origsigma strat cl)))
+    (fun (e, info) -> match e with
+    | RewriteFailure e ->
+      tclFAIL 0 (str"setoid rewrite failed: " ++ e)
+    | e -> Proofview.tclZERO ~info e)
+  end }
 
-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
+let _ = Hook.set Equality.general_setoid_rewrite_clause general_s_rewrite
 
 (** [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")
+  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 Coq.Classes.RelationClasses library")
 
 let setoid_proof ty fn fallback =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
     let env = Proofview.Goal.env gl in
-    let sigma = Proofview.Goal.sigma gl in
+    let sigma = Tacmach.New.project 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.unsafe_type_of env evm rel)))) in
-	    (try init_setoid () with _ -> raise Not_found);
+          let open Context.Rel.Declaration in
+          let (sigma, t) = Typing.type_of env sigma rel in
+          let car = get_type (List.hd (fst (Reduction.dest_prod env t))) in
+	    (try init_relation_classes () with _ -> raise Not_found);
             fn env sigma car rel
         with e -> Proofview.tclZERO e
       end
@@ -2069,11 +2143,10 @@ let setoid_proof ty fn fallback =
                 | e' -> Proofview.tclZERO ~info e'
               end
       end
-  end
+  end }
 
 let tac_open ((evm,_), c) tac = 
-  Proofview.V82.tactic 
-    (tclTHEN (Refiner.tclEVARS evm) (tac c))
+    (tclTHEN (Proofview.Unsafe.tclEVARS evm) (tac c))
 
 let poly_proof getp gett env evm car rel =
   if Sorts.is_prop (sort_of_rel env evm rel) then
@@ -2086,7 +2159,7 @@ let setoid_reflexivity =
      tac_open (poly_proof PropGlobal.get_reflexive_proof
 			  TypeGlobal.get_reflexive_proof
 			  env evm car rel)
-	      (fun c -> tclCOMPLETE (Proofview.V82.of_tactic (apply c))))
+	      (fun c -> tclCOMPLETE (apply c)))
     (reflexivity_red true)
 
 let setoid_symmetry =
@@ -2095,7 +2168,7 @@ let setoid_symmetry =
       tac_open
 	(poly_proof PropGlobal.get_symmetric_proof TypeGlobal.get_symmetric_proof
 	   env evm car rel)
-	(fun c -> Proofview.V82.of_tactic (apply c)))
+	(fun c -> apply c))
     (symmetry_red true)
     
 let setoid_transitivity c =
@@ -2104,8 +2177,8 @@ let setoid_transitivity c =
       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 ]))))
+	| None -> eapply proof
+	| Some c -> apply_with_bindings (proof,ImplicitBindings [ c ])))
     (transitivity_red true c)
     
 let setoid_symmetry_in id =
@@ -2123,9 +2196,9 @@ let setoid_symmetry_in id =
   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
+    (tclTHENLAST
       (Tactics.assert_after_replacing id new_hyp)
-      (Tacticals.New.tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ]))
+      (tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ]))
       gl)
 
 let _ = Hook.set Tactics.setoid_reflexivity setoid_reflexivity
diff --git a/tactics/rewrite.mli b/ltac/rewrite.mli
index b4d47d62..35c44835 100644
--- a/tactics/rewrite.mli
+++ b/ltac/rewrite.mli
@@ -62,16 +62,19 @@ val strategy_of_ast : (glob_constr_and_expr, raw_red_expr) strategy_ast -> strat
 val map_strategy : ('a -> 'b) -> ('c -> 'd) ->
   ('a, 'c) strategy_ast -> ('b, 'd) strategy_ast
 
+val pr_strategy : ('a -> Pp.std_ppcmds) -> ('b -> Pp.std_ppcmds) ->
+  ('a, 'b) strategy_ast -> Pp.std_ppcmds
+
 (** Entry point for user-level "rewrite_strat" *)
-val cl_rewrite_clause_strat : strategy -> Id.t option -> tactic
+val cl_rewrite_clause_strat : strategy -> Id.t option -> unit Proofview.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
+  bool -> Locus.occurrences -> Id.t option -> unit Proofview.tactic
 
 val is_applied_rewrite_relation :
-  env -> evar_map -> Context.rel_context -> constr -> types option
+  env -> evar_map -> Context.Rel.t -> constr -> types option
 
 val declare_relation :
   ?binders:local_binder list -> constr_expr -> constr_expr -> Id.t ->
diff --git a/tactics/taccoerce.ml b/ltac/taccoerce.ml
index 25f5c8e9..b0a80ef7 100644
--- a/tactics/taccoerce.ml
+++ b/ltac/taccoerce.ml
@@ -14,25 +14,47 @@ open Misctypes
 open Genarg
 open Stdarg
 open Constrarg
+open Geninterp
 
 exception CannotCoerceTo of string
 
 let (wit_constr_context : (Empty.t, Empty.t, constr) Genarg.genarg_type) =
-  Genarg.create_arg None "constr_context"
+  let wit = Genarg.create_arg "constr_context" in
+  let () = register_val0 wit None in
+  wit
 
 (* 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"
+  let wit = Genarg.create_arg "constr_under_binders" in
+  let () = register_val0 wit None in
+  wit
+
+(** All the types considered here are base types *)
+let val_tag wit = match val_tag wit with
+| Val.Base t -> t
+| _ -> assert false
+
+let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit ->
+  let Val.Dyn (t, _) = v in
+  match Val.eq t (val_tag wit) with
+  | None -> false
+  | Some Refl -> true
+
+let prj : type a. a Val.typ -> Val.t -> a option = fun t v ->
+  let Val.Dyn (t', x) = v in
+  match Val.eq t t' with
+  | None -> None
+  | Some Refl -> Some x
+
+let in_gen wit v = Val.Dyn (val_tag wit, v)
+let out_gen wit v = match prj (val_tag wit) v with None -> assert false | Some x -> x
 
 module Value =
 struct
 
-type t = tlevel generic_argument
+type t = Val.t
 
-let rec normalize v =
-  if has_type v (topwit wit_genarg) then
-    normalize (out_gen (topwit wit_genarg) v)
-  else v
+let normalize v = v
 
 let of_constr c = in_gen (topwit wit_constr) c
 
@@ -62,11 +84,11 @@ let to_int v =
     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
+let to_list v = prj Val.typ_list v
+
+let to_option v = prj Val.typ_opt v
+
+let to_pair v = prj Val.typ_pair v
 
 end
 
@@ -85,7 +107,7 @@ let coerce_to_constr_context v =
   else raise (CannotCoerceTo "a term context")
 
 (* Interprets an identifier which must be fresh *)
-let coerce_to_ident fresh env v =
+let coerce_var_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
@@ -102,6 +124,52 @@ let coerce_to_ident fresh env v =
       destVar c
     else fail ()
 
+
+(* Interprets, if possible, a constr to an identifier which may not
+   be fresh but suitable to be given to the fresh tactic. Works for
+   vars, constants, inductive, constructors and sorts. *)
+let coerce_to_ident_not_fresh g env v =
+let id_of_name = function
+  | Names.Anonymous -> Id.of_string "x"
+  | Names.Name x -> x in
+  let v = Value.normalize v in
+  let fail () = raise (CannotCoerceTo "an 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 ->
+       match Constr.kind c with
+       | Var id -> id 
+       | Meta m -> id_of_name (Evd.meta_name g m)
+       | Evar (kn,_) ->
+        begin match Evd.evar_ident kn g with
+        | None -> fail ()
+        | Some id -> id
+        end
+       | Const (cst,_) -> Label.to_id (Constant.label cst)
+       | Construct (cstr,_) ->
+	  let ref = Globnames.ConstructRef cstr in
+	  let basename = Nametab.basename_of_global ref in
+	  basename
+       | Ind (ind,_) ->
+	  let ref = Globnames.IndRef ind in
+	  let basename = Nametab.basename_of_global ref in
+	  basename
+       | Sort s ->
+	  begin
+	    match s with
+	    | Prop _ -> Label.to_id (Label.make "Prop")
+	    | Type _ -> Label.to_id (Label.make "Type")
+	  end
+       | _ -> fail()
+
+
 let coerce_to_intro_pattern env v =
   let v = Value.normalize v in
   if has_type v (topwit wit_intro_pattern) then
@@ -168,6 +236,7 @@ let coerce_to_closed_constr env v =
 let coerce_to_evaluable_ref env v =
   let fail () = raise (CannotCoerceTo "an evaluable reference") in
   let v = Value.normalize v in
+  let ev =
   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
@@ -184,12 +253,11 @@ let coerce_to_evaluable_ref env v =
     | ConstRef c -> EvalConstRef c
     | IndRef _ | ConstructRef _ -> fail ()
   else
-    let ev = match Value.to_constr v with
+    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 ()
+  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
diff --git a/tactics/taccoerce.mli b/ltac/taccoerce.mli
index d26a477e..0b67f872 100644
--- a/tactics/taccoerce.mli
+++ b/ltac/taccoerce.mli
@@ -12,6 +12,7 @@ open Term
 open Misctypes
 open Pattern
 open Genarg
+open Geninterp
 
 (** Coercions from highest level generic arguments to actual data used by Ltac
     interpretation. Those functions examinate dynamic types and try to return
@@ -29,8 +30,7 @@ exception CannotCoerceTo of string
 
 module Value :
 sig
-  type t = tlevel generic_argument
-  (** Tactics manipulate [tlevel generic_argument]. *)
+  type t = Val.t
 
   val normalize : t -> t
   (** Eliminated the leading dynamic type casts. *)
@@ -42,18 +42,19 @@ sig
   val of_int : int -> t
   val to_int : t -> int option
   val to_list : t -> t list option
+  val to_option : t -> t option option
+  val to_pair : t -> (t * t) 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_var_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_ident_not_fresh : Evd.evar_map -> Environ.env -> Value.t -> Id.t
 
-val coerce_to_intro_pattern_naming :
-  Environ.env -> Value.t -> intro_pattern_naming_expr
+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
diff --git a/ltac/tacentries.ml b/ltac/tacentries.ml
new file mode 100644
index 00000000..673ac832
--- /dev/null
+++ b/ltac/tacentries.ml
@@ -0,0 +1,513 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Pp
+open CErrors
+open Util
+open Names
+open Libobject
+open Genarg
+open Extend
+open Pcoq
+open Egramml
+open Egramcoq
+open Vernacexpr
+open Libnames
+open Nameops
+
+type 'a grammar_tactic_prod_item_expr = 'a Pptactic.grammar_tactic_prod_item_expr =
+| TacTerm of string
+| TacNonTerm of Loc.t * 'a * Names.Id.t
+
+type raw_argument = string * string option
+type argument = Genarg.ArgT.any Extend.user_symbol
+
+(**********************************************************************)
+(* 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 atactic n =
+  if n = 5 then Aentry Tactic.binder_tactic
+  else Aentryl (Tactic.tactic_expr, n)
+
+type entry_name = EntryName :
+  'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) Extend.symbol -> entry_name
+
+(** Quite ad-hoc *)
+let get_tacentry n m =
+  let check_lvl n =
+    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
+  if check_lvl n then EntryName (rawwit Constrarg.wit_tactic, Aself)
+  else if check_lvl (n + 1) then EntryName (rawwit Constrarg.wit_tactic, Anext)
+  else EntryName (rawwit Constrarg.wit_tactic, atactic n)
+
+let get_separator = function
+| None -> error "Missing separator."
+| Some sep -> sep
+
+let rec parse_user_entry s sep =
+  let l = String.length s in
+  if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then
+    let entry = parse_user_entry (String.sub s 3 (l-8)) None in
+    Ulist1 entry
+  else if l > 12 && coincide s "ne_" 0 &&
+                   coincide s "_list_sep" (l-9) then
+    let entry = parse_user_entry (String.sub s 3 (l-12)) None in
+    Ulist1sep (entry, get_separator sep)
+  else if l > 5 && coincide s "_list" (l-5) then
+    let entry = parse_user_entry (String.sub s 0 (l-5)) None in
+    Ulist0 entry
+  else if l > 9 && coincide s "_list_sep" (l-9) then
+    let entry = parse_user_entry (String.sub s 0 (l-9)) None in
+    Ulist0sep (entry, get_separator sep)
+  else if l > 4 && coincide s "_opt" (l-4) then
+    let entry = parse_user_entry (String.sub s 0 (l-4)) None in
+    Uopt entry
+  else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then
+    let n = Char.code s.[6] - 48 in
+    Uentryl ("tactic", n)
+  else
+    Uentry s
+
+let arg_list = function Rawwit t -> Rawwit (ListArg t)
+let arg_opt = function Rawwit t -> Rawwit (OptArg t)
+
+let interp_entry_name interp symb =
+  let rec eval = function
+  | Ulist1 e -> Ulist1 (eval e)
+  | Ulist1sep (e, sep) -> Ulist1sep (eval e, sep)
+  | Ulist0 e -> Ulist0 (eval e)
+  | Ulist0sep (e, sep) -> Ulist0sep (eval e, sep)
+  | Uopt e -> Uopt (eval e)
+  | Uentry s -> Uentry (interp s None)
+  | Uentryl (s, n) -> Uentryl (interp s (Some n), n)
+  in
+  eval symb
+
+(**********************************************************************)
+(** Grammar declaration for Tactic Notation (Coq level)               *)
+
+let get_tactic_entry n =
+  if Int.equal n 0 then
+    Tactic.simple_tactic, None
+  else if Int.equal n 5 then
+    Tactic.binder_tactic, None
+  else if 1<=n && n<5 then
+    Tactic.tactic_expr, Some (Extend.Level (string_of_int n))
+  else
+    error ("Invalid Tactic Notation level: "^(string_of_int n)^".")
+
+(**********************************************************************)
+(** State of the grammar extensions                                   *)
+
+type tactic_grammar = {
+  tacgram_level : int;
+  tacgram_prods : Pptactic.grammar_terminals;
+}
+
+(* Declaration of the tactic grammar rule *)
+
+let head_is_ident tg = match tg.tacgram_prods with
+| TacTerm _ :: _ -> true
+| _ -> false
+
+let rec prod_item_of_symbol lev = function
+| Extend.Ulist1 s ->
+  let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in
+  EntryName (Rawwit (ListArg typ), Alist1 e)
+| Extend.Ulist0 s ->
+  let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in
+  EntryName (Rawwit (ListArg typ), Alist0 e)
+| Extend.Ulist1sep (s, sep) ->
+  let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in
+  EntryName (Rawwit (ListArg typ), Alist1sep (e, Atoken (CLexer.terminal sep)))
+| Extend.Ulist0sep (s, sep) ->
+  let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in
+  EntryName (Rawwit (ListArg typ), Alist0sep (e, Atoken (CLexer.terminal sep)))
+| Extend.Uopt s ->
+  let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in
+  EntryName (Rawwit (OptArg typ), Aopt e)
+| Extend.Uentry arg ->
+  let ArgT.Any tag = arg in
+  let wit = ExtraArg tag in
+  EntryName (Rawwit wit, Extend.Aentry (genarg_grammar wit))
+| Extend.Uentryl (s, n) ->
+  let ArgT.Any tag = s in
+  assert (coincide (ArgT.repr tag) "tactic" 0);
+  get_tacentry n lev
+
+(** Tactic grammar extensions *)
+
+let add_tactic_entry (kn, ml, tg) state =
+  let open Tacexpr in
+  let entry, pos = get_tactic_entry tg.tacgram_level in
+  let mkact loc l =
+    let map arg =
+      (** HACK to handle especially the tactic(...) entry *)
+      let wit = Genarg.rawwit Constrarg.wit_tactic in
+      if Genarg.has_type arg wit && not ml then
+        Tacexp (Genarg.out_gen wit arg)
+      else
+        TacGeneric arg
+    in
+    let l = List.map map l in
+    (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 map = function
+  | TacTerm s -> GramTerminal s
+  | TacNonTerm (loc, s, _) ->
+    let EntryName (typ, e) = prod_item_of_symbol tg.tacgram_level s in
+    GramNonTerminal (loc, typ, e)
+  in
+  let prods = List.map map tg.tacgram_prods in
+  let rules = make_rule mkact prods in
+  let r = ExtendRule (entry, None, (pos, [(None, None, [rules])])) in
+  ([r], state)
+
+let tactic_grammar =
+  create_grammar_command "TacticGrammar" add_tactic_entry
+
+let extend_tactic_grammar kn ml ntn = extend_grammar_command tactic_grammar (kn, ml, ntn)
+
+(**********************************************************************)
+(* Tactic Notation                                                    *)
+
+let entry_names = ref String.Map.empty
+
+let register_tactic_notation_entry name entry =
+  let entry = match entry with
+  | ExtraArg arg -> ArgT.Any arg
+  | _ -> assert false
+  in
+  entry_names := String.Map.add name entry !entry_names
+
+let interp_prod_item = function
+  | TacTerm s -> TacTerm s
+  | TacNonTerm (loc, (nt, sep), id) ->
+    let symbol = parse_user_entry nt sep in
+    let interp s = function
+    | None ->
+      if String.Map.mem s !entry_names then String.Map.find s !entry_names
+      else begin match ArgT.name s with
+      | None -> error ("Unknown entry "^s^".")
+      | Some arg -> arg
+      end
+    | Some n ->
+      (** FIXME: do better someday *)
+      assert (String.equal s "tactic");
+      begin match Constrarg.wit_tactic with
+      | ExtraArg tag -> ArgT.Any tag
+      | _ -> assert false
+      end
+    in
+    let symbol = interp_entry_name interp symbol in
+    TacNonTerm (loc, symbol, id)
+
+let make_fresh_key =
+  let id = Summary.ref ~name:"TACTIC-NOTATION-COUNTER" 0 in
+  fun prods ->
+    let cur = incr id; !id in
+    let map = function
+    | TacTerm s -> s
+    | TacNonTerm _ -> "#"
+    in
+    let prods = String.concat "_" (List.map map prods) in
+    (** We embed the hash of the kernel name in the label so that the identifier
+        should be mostly unique. This ensures that including two modules
+        together won't confuse the corresponding labels. *)
+    let hash = (cur lxor (ModPath.hash (Lib.current_mp ()))) land 0x7FFFFFFF in
+    let lbl = Id.of_string_soft (Printf.sprintf "%s_%08X" prods hash) in
+    Lib.make_kn lbl
+
+type tactic_grammar_obj = {
+  tacobj_key : KerName.t;
+  tacobj_local : locality_flag;
+  tacobj_tacgram : tactic_grammar;
+  tacobj_body : Id.t list * Tacexpr.glob_tactic_expr;
+  tacobj_forml : bool;
+}
+
+let pprule pa = {
+  Pptactic.pptac_level = pa.tacgram_level;
+  pptac_prods = pa.tacgram_prods;
+}
+
+let check_key key =
+  if Tacenv.check_alias key then
+    error "Conflicting tactic notations keys. This can happen when including \
+    twice the same module."
+
+let cache_tactic_notation (_, tobj) =
+  let key = tobj.tacobj_key in
+  let () = check_key key in
+  Tacenv.register_alias key tobj.tacobj_body;
+  extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram;
+  Pptactic.declare_notation_tactic_pprule key (pprule tobj.tacobj_tacgram)
+
+let open_tactic_notation i (_, tobj) =
+  let key = tobj.tacobj_key in
+  if Int.equal i 1 && not tobj.tacobj_local then
+    extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram
+
+let load_tactic_notation i (_, tobj) =
+  let key = tobj.tacobj_key in
+  let () = check_key key in
+  (** Only add the printing and interpretation rules. *)
+  Tacenv.register_alias key tobj.tacobj_body;
+  Pptactic.declare_notation_tactic_pprule key (pprule tobj.tacobj_tacgram);
+  if Int.equal i 1 && not tobj.tacobj_local then
+    extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram
+
+let subst_tactic_notation (subst, tobj) =
+  let (ids, body) = tobj.tacobj_body in
+  { tobj with
+    tacobj_key = Mod_subst.subst_kn subst tobj.tacobj_key;
+    tacobj_body = (ids, Tacsubst.subst_tactic subst body);
+  }
+
+let classify_tactic_notation tacobj = Substitute tacobj
+
+let inTacticGrammar : tactic_grammar_obj -> obj =
+  declare_object {(default_object "TacticGrammar") with
+       open_function = open_tactic_notation;
+       load_function = load_tactic_notation;
+       cache_function = cache_tactic_notation;
+       subst_function = subst_tactic_notation;
+       classify_function = classify_tactic_notation}
+
+let cons_production_parameter = function
+| TacTerm _ -> None
+| TacNonTerm (_, _, id) -> Some id
+
+let add_glob_tactic_notation local n prods forml ids tac =
+  let parule = {
+    tacgram_level = n;
+    tacgram_prods = prods;
+  } in
+  let tacobj = {
+    tacobj_key = make_fresh_key prods;
+    tacobj_local = local;
+    tacobj_tacgram = parule;
+    tacobj_body = (ids, tac);
+    tacobj_forml = forml;
+  } in
+  Lib.add_anonymous_leaf (inTacticGrammar tacobj)
+
+let add_tactic_notation local n prods e =
+  let ids = List.map_filter cons_production_parameter prods in
+  let prods = List.map interp_prod_item prods in
+  let tac = Tacintern.glob_tactic_env ids (Global.env()) e in
+  add_glob_tactic_notation local n prods false ids tac
+
+(**********************************************************************)
+(* ML Tactic entries                                                  *)
+
+exception NonEmptyArgument
+
+(** ML tactic notations whose use can be restricted to an identifier are added
+    as true Ltac entries. *)
+let extend_atomic_tactic name entries =
+  let open Tacexpr in
+  let map_prod prods =
+    let (hd, rem) = match prods with
+    | TacTerm s :: rem -> (s, rem)
+    | _ -> assert false (** Not handled by the ML extension syntax *)
+    in
+    let empty_value = function
+    | TacTerm s -> raise NonEmptyArgument
+    | TacNonTerm (_, symb, _) ->
+      let EntryName (typ, e) = prod_item_of_symbol 0 symb in
+      let Genarg.Rawwit wit = typ in
+      let inj x = TacArg (Loc.ghost, TacGeneric (Genarg.in_gen typ x)) in
+      let default = epsilon_value inj e in
+      match default with
+      | None -> raise NonEmptyArgument
+      | Some def -> Tacintern.intern_tactic_or_tacarg Tacintern.fully_empty_glob_sign def
+    in
+    try Some (hd, List.map empty_value rem) with NonEmptyArgument -> None
+  in
+  let entries = List.map map_prod entries in
+  let add_atomic i args = match args with
+  | None -> ()
+  | Some (id, args) ->
+    let args = List.map (fun a -> Tacexp a) args in
+    let entry = { mltac_name = name; mltac_index = i } in
+    let body = TacML (Loc.ghost, entry, args) in
+    Tacenv.register_ltac false false (Names.Id.of_string id) body
+  in
+  List.iteri add_atomic entries
+
+let add_ml_tactic_notation name prods =
+  let len = List.length prods in
+  let iter i prods =
+    let open Tacexpr in
+    let get_id = function
+    | TacTerm s -> None
+    | TacNonTerm (_, _, id) -> Some id
+    in
+    let ids = List.map_filter get_id prods in
+    let entry = { mltac_name = name; mltac_index = len - i - 1 } in
+    let map id = Reference (Misctypes.ArgVar (Loc.ghost, id)) in
+    let tac = TacML (Loc.ghost, entry, List.map map ids) in
+    add_glob_tactic_notation false 0 prods true ids tac
+  in
+  List.iteri iter (List.rev prods);
+  extend_atomic_tactic name prods
+
+(**********************************************************************)
+(** Ltac quotations                                                   *)
+
+let ltac_quotations = ref String.Set.empty
+
+let create_ltac_quotation name cast (e, l) =
+  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 entry = match l with
+  | None -> Aentry e
+  | Some l -> Aentryl (e, l)
+  in
+(*   let level = Some "1" in *)
+  let level = None in
+  let assoc = None in
+  let rule =
+    Next (Next (Next (Next (Next (Stop,
+      Atoken (CLexer.terminal name)),
+      Atoken (CLexer.terminal ":")),
+      Atoken (CLexer.terminal "(")),
+      entry),
+      Atoken (CLexer.terminal ")"))
+  in
+  let action _ v _ _ _ loc = cast (loc, v) in
+  let gram = (level, assoc, [Rule (rule, action)]) in
+  Pcoq.grammar_extend Tactic.tactic_arg None (None, [gram])
+
+(** Command *)
+
+
+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 warn_unusable_identifier =
+  CWarnings.create ~name:"unusable-identifier" ~category:"parsing"
+      (fun id -> strbrk "The Ltac name" ++ spc () ++ pr_id id ++ spc () ++
+        strbrk "may be unusable because of a conflict with a notation.")
+
+let register_ltac local tacl =
+  let map tactic_body =
+    match tactic_body with
+    | TacticDefinition ((loc,id), body) ->
+        let kn = Lib.make_kn id in
+        let id_pp = pr_id id in
+        let () = if is_defined_tac kn then
+          CErrors.user_err_loc (loc, "",
+            str "There is already an Ltac named " ++ id_pp ++ str".")
+        in
+        let is_shadowed =
+          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 CErrors.noncritical e -> true (* prim tactics with args, e.g. "apply" *)
+        in
+        let () = if is_shadowed then warn_unusable_identifier id in
+        NewTac id, body
+    | TacticRedefinition (ident, body) ->
+        let loc = loc_of_reference ident in
+        let kn =
+          try Nametab.locate_tactic (snd (qualid_of_reference ident))
+          with Not_found ->
+            CErrors.user_err_loc (loc, "",
+                        str "There is no Ltac named " ++ pr_reference ident ++ str ".")
+        in
+        UpdateTac kn, body
+  in
+  let rfun = List.map map tacl in
+  let recvars =
+    let fold accu (op, _) = match op with
+    | UpdateTac _ -> accu
+    | NewTac id -> (Lib.make_path id, Lib.make_kn id) :: accu
+    in
+    List.fold_left fold [] rfun
+  in
+  let ist = Tacintern.make_empty_glob_sign () 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 () =
+    (** Register locally the tactic to handle recursivity. This function affects
+        the whole environment, so that we transactify it afterwards. *)
+    let iter_rec (sp, kn) = Nametab.push_tactic (Nametab.Until 1) sp kn in
+    let () = List.iter iter_rec recvars in
+    List.map map rfun
+  in
+  let defs = Future.transactify defs () in
+  let iter (def, tac) = match def with
+  | NewTac id ->
+    Tacenv.register_ltac false local id tac;
+    Flags.if_verbose Feedback.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 Feedback.msg_info (Libnames.pr_qualid name ++ str " is redefined")
+  in
+  List.iter iter defs
+
+(** Queries *)
+
+let print_ltacs () =
+  let entries = KNmap.bindings (Tacenv.ltac_entries ()) in
+  let sort (kn1, _) (kn2, _) = KerName.compare kn1 kn2 in
+  let entries = List.sort sort entries in
+  let map (kn, entry) =
+    let qid =
+      try Some (Nametab.shortest_qualid_of_tactic kn)
+      with Not_found -> None
+    in
+    match qid with
+    | None -> None
+    | Some qid -> Some (qid, entry.Tacenv.tac_body)
+  in
+  let entries = List.map_filter map entries in
+  let pr_entry (qid, body) =
+    let (l, t) = match body with
+    | Tacexpr.TacFun (l, t) -> (l, t)
+    | _ -> ([], body)
+    in
+    let pr_ltac_fun_arg = function
+    | None -> spc () ++ str "_"
+    | Some id -> spc () ++ pr_id id
+    in
+    hov 2 (pr_qualid qid ++ prlist pr_ltac_fun_arg l)
+  in
+  Feedback.msg_notice (prlist_with_sep fnl pr_entry entries)
diff --git a/ltac/tacentries.mli b/ltac/tacentries.mli
new file mode 100644
index 00000000..27df819e
--- /dev/null
+++ b/ltac/tacentries.mli
@@ -0,0 +1,64 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Ltac toplevel command entries. *)
+
+open Vernacexpr
+open Tacexpr
+
+(** {5 Tactic Definitions} *)
+
+val register_ltac : locality_flag -> Vernacexpr.tacdef_body list -> unit
+(** Adds new Ltac definitions to the environment. *)
+
+(** {5 Tactic Notations} *)
+
+type 'a grammar_tactic_prod_item_expr = 'a Pptactic.grammar_tactic_prod_item_expr =
+| TacTerm of string
+| TacNonTerm of Loc.t * 'a * Names.Id.t
+
+type raw_argument = string * string option
+(** An argument type as provided in Tactic notations, i.e. a string like
+    "ne_foo_list_opt" together with a separator that only makes sense in the
+    "_sep" cases. *)
+
+type argument = Genarg.ArgT.any Extend.user_symbol
+(** A fully resolved argument type given as an AST with generic arguments on the
+    leaves. *)
+
+val add_tactic_notation :
+  locality_flag -> int -> raw_argument grammar_tactic_prod_item_expr list ->
+  raw_tactic_expr -> unit
+(** [add_tactic_notation local level prods expr] adds a tactic notation in the
+    environment at level [level] with locality [local] made of the grammar
+    productions [prods] and returning the body [expr] *)
+
+val register_tactic_notation_entry : string -> ('a, 'b, 'c) Genarg.genarg_type -> unit
+(** Register an argument under a given entry name for tactic notations. When
+    translating [raw_argument] into [argument], atomic names will be first
+    looked up according to names registered through this function and fallback
+    to finding an argument by name (as in {!Genarg}) if there is none
+    matching. *)
+
+val add_ml_tactic_notation : ml_tactic_name ->
+  argument grammar_tactic_prod_item_expr list list -> unit
+(** A low-level variant of {!add_tactic_notation} used by the TACTIC EXTEND
+    ML-side macro. *)
+
+(** {5 Tactic Quotations} *)
+
+val create_ltac_quotation : string ->
+  ('grm Loc.located -> raw_tactic_arg) -> ('grm Pcoq.Gram.entry * int option) -> unit
+(** [create_ltac_quotation name f e] adds a quotation rule to Ltac, that is,
+    Ltac grammar now accepts arguments of the form ["name" ":" "(" <e> ")"], and
+    generates an argument using [f] on the entry parsed by [e]. *)
+
+(** {5 Queries} *)
+
+val print_ltacs : unit -> unit
+(** Display the list of ltac definitions currently available. *)
diff --git a/tactics/tacenv.ml b/ltac/tacenv.ml
index dc89a71e..c709ab11 100644
--- a/tactics/tacenv.ml
+++ b/ltac/tacenv.ml
@@ -7,7 +7,6 @@
 (************************************************************************)
 
 open Util
-open Genarg
 open Pp
 open Names
 open Tacexpr
@@ -15,23 +14,24 @@ open Tacexpr
 (** Tactic notations (TacAlias) *)
 
 type alias = KerName.t
+type alias_tactic = Id.t list * glob_tactic_expr
 
 let alias_map = Summary.ref ~name:"tactic-alias"
-  (KNmap.empty : glob_tactic_expr KNmap.t)
+  (KNmap.empty : alias_tactic 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)
+  with Not_found -> CErrors.anomaly (str "Unknown tactic alias: " ++ KerName.print key)
 
 let check_alias key = KNmap.mem key !alias_map
 
 (** ML tactic extensions (TacML) *)
 
 type ml_tactic =
-  typed_generic_argument list -> Geninterp.interp_sign -> unit Proofview.tactic
+  Geninterp.Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic
 
 module MLName =
 struct
@@ -49,22 +49,23 @@ let pr_tacname t =
 
 let tac_tab = ref MLTacMap.empty
 
-let register_ml_tactic ?(overwrite = false) s (t : ml_tactic) =
+let register_ml_tactic ?(overwrite = false) s (t : ml_tactic array) =
   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)
+        tac_tab := MLTacMap.remove s !tac_tab
       else
-        Errors.anomaly (str "Cannot redeclare tactic " ++ pr_tacname s ++ str ".")
+        CErrors.anomaly (str "Cannot redeclare tactic " ++ pr_tacname s ++ str ".")
   in
   tac_tab := MLTacMap.add s t !tac_tab
 
-let interp_ml_tactic s =
+let interp_ml_tactic { mltac_name = s; mltac_index = i } =
   try
-    MLTacMap.find s !tac_tab
+    let tacs = MLTacMap.find s !tac_tab in
+    let () = if Array.length tacs <= i then raise Not_found in
+    tacs.(i)
   with Not_found ->
-    Errors.errorlabstrm ""
+    CErrors.errorlabstrm ""
       (str "The tactic " ++ pr_tacname s ++ str " is not installed.")
 
 (***************************************************************************)
diff --git a/tactics/tacenv.mli b/ltac/tacenv.mli
index 87cdce65..94e14223 100644
--- a/tactics/tacenv.mli
+++ b/ltac/tacenv.mli
@@ -9,6 +9,7 @@
 open Genarg
 open Names
 open Tacexpr
+open Geninterp
 
 (** This module centralizes the various ways of registering tactics. *)
 
@@ -17,10 +18,13 @@ open Tacexpr
 type alias = KerName.t
 (** Type of tactic alias, used in the [TacAlias] node. *)
 
-val register_alias : alias -> glob_tactic_expr -> unit
+type alias_tactic = Id.t list * glob_tactic_expr
+(** Contents of a tactic notation *)
+
+val register_alias : alias -> alias_tactic -> unit
 (** Register a tactic alias. *)
 
-val interp_alias : alias -> glob_tactic_expr
+val interp_alias : alias -> alias_tactic
 (** Recover the the body of an alias. Raises an anomaly if it does not exist. *)
 
 val check_alias : alias -> bool
@@ -61,11 +65,11 @@ val ltac_entries : unit -> ltac_entry KNmap.t
 (** {5 ML tactic extensions} *)
 
 type ml_tactic =
-  typed_generic_argument list -> Geninterp.interp_sign -> unit Proofview.tactic
+  Val.t 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
+val register_ml_tactic : ?overwrite:bool -> ml_tactic_name -> ml_tactic array -> unit
 (** Register an external tactic. *)
 
-val interp_ml_tactic : ml_tactic_name -> ml_tactic
+val interp_ml_tactic : ml_tactic_entry -> ml_tactic
 (** Get the named tactic. Raises a user error if it does not exist. *)
diff --git a/tactics/tacintern.ml b/ltac/tacintern.ml
index 11f2c594..c5bb0ed0 100644
--- a/tactics/tacintern.ml
+++ b/ltac/tacintern.ml
@@ -11,7 +11,7 @@ open Pp
 open Genredexpr
 open Glob_term
 open Tacred
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
@@ -35,11 +35,6 @@ 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.")
 
@@ -97,7 +92,6 @@ let intern_or_var f ist = function
   | 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
@@ -259,8 +253,11 @@ and intern_intro_pattern_action lf ist = function
   | 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))
+and intern_or_and_intro_pattern lf ist = function
+   | IntroAndPattern l ->
+      IntroAndPattern (List.map (intern_intro_pattern lf ist) l)
+  | IntroOrPattern ll ->
+      IntroOrPattern (List.map (List.map (intern_intro_pattern lf ist)) ll)
 
 let intern_or_and_intro_pattern_loc lf ist = function
   | ArgVar (_,id) as x ->
@@ -272,7 +269,7 @@ 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
+let intern_destruction_arg ist = function
   | clear,ElimOnConstr c -> clear,ElimOnConstr (intern_constr_with_bindings ist c)
   | clear,ElimOnAnonHyp n as x -> x
   | clear,ElimOnIdent (loc,id) ->
@@ -328,8 +325,9 @@ let intern_constr_pattern ist ~as_type ~ltacvars pc =
   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 (glob,_ as c) = intern_constr_gen true false ist pc in
+  let bound_names = Glob_ops.bound_glob_vars glob in
+  metas,(bound_names,c,pat)
 
 let dummy_pat = PRel 0
 
@@ -337,9 +335,11 @@ 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 (glob,_ as c) = intern_constr_gen true false ist p in
+  let bound_names = Glob_ops.bound_glob_vars glob in
+  (bound_names,c,dummy_pat)
 
-let rec intern_typed_pattern_or_ref_with_occurrences ist (l,p) =
+let intern_typed_pattern_or_ref_with_occurrences ist (l,p) =
   let interp_ref r =
     try Inl (intern_evaluable ist r)
     with e when Logic.catchable_exception e ->
@@ -361,7 +361,8 @@ let rec intern_typed_pattern_or_ref_with_occurrences ist (l,p) =
           let r = evaluable_of_global_reference ist.genv (VarRef id) in
           Inl (ArgArg (r,None))
       | _ ->
-          Inr ((c,None),dummy_pat) in
+          let bound_names = Glob_ops.bound_glob_vars c in
+          Inr (bound_names,(c,None),dummy_pat) in
   (l, match p with
   | Inl r -> interp_ref r
   | Inr (CAppExpl(_,(None,r,None),[])) ->
@@ -377,13 +378,13 @@ let dump_glob_red_expr = function
     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
+    with e when CErrors.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
+      with e when CErrors.noncritical e -> ()) grf.rConst
   | _ -> ()
 
 let intern_red_expr ist = function
@@ -423,7 +424,7 @@ let intern_hyp_location ist ((occs,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
+      let (metas,pc) = intern_constr_pattern ist ~as_type:false ~ltacvars pc in
       ido, metas, Subterm (b,ido,pc)
   | Term pc ->
       let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in
@@ -445,7 +446,7 @@ let opt_cons accu = function
 | Some id -> Id.Set.add id accu
 
 (* Reads the hypotheses of a "match goal" rule *)
-let rec intern_match_goal_hyps ist lfun = function
+let rec intern_match_goal_hyps ist ?(as_type=false) 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
@@ -454,7 +455,7 @@ let rec intern_match_goal_hyps ist lfun = function
   | (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, metas3, hyps = intern_match_goal_hyps ist ~as_type 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, [], []
@@ -474,19 +475,12 @@ let clause_app f = function
   | { 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)
+  | TacIntroPattern (ev,l) ->
+      TacIntroPattern (ev,List.map (intern_intro_pattern lf ist) l)
   | 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)
@@ -494,60 +488,34 @@ let rec intern_atomic lf ist x =
       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,
+      TacAssert (b,Option.map (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,
+	      (intern_destruction_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;
@@ -569,10 +537,6 @@ let rec intern_atomic lf ist x =
       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
@@ -600,7 +564,7 @@ and intern_tactic_seq onlytac ist = function
       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)
+      ist.ltacvars, TacMatchGoal(lz,lr, intern_match_rule onlytac ist ~as_type:true lmr)
   | TacMatch (lz,c,lmr) ->
       ist.ltacvars,
       TacMatch (lz,intern_tactic_or_tacarg ist c,intern_match_rule onlytac ist lmr)
@@ -660,23 +624,24 @@ and intern_tactic_seq onlytac ist = function
   | 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
+  | TacSelect (sel, tac) ->
+      ist.ltacvars, TacSelect (sel, intern_pure_tactic ist tac)
 
   (* For extensions *)
   | TacAlias (loc,s,l) ->
-      let l = List.map (fun (id,a) -> (id,intern_genarg ist a)) l in
+      let l = List.map (intern_tacarg !strict_check false ist) 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)
+      ist.ltacvars, TacML (adjust_loc loc,opn,List.map (intern_tacarg !strict_check false 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)
+  | TacGeneric _ as a -> TacArg (loc,a)
   | Tacexp a -> a
-  | ConstrMayEval _ | UConstr _ | TacFreshId _ | TacPretype _ | TacNumgoals as a ->
+  | ConstrMayEval _ | 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
 
@@ -689,14 +654,6 @@ and intern_tactic_fun ist (var,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,
@@ -707,82 +664,47 @@ and intern_tacarg strict onlytac ist = function
   | TacNumgoals -> TacNumgoals
   | Tacexp t -> Tacexp (intern_tactic onlytac ist t)
   | TacGeneric arg ->
-    let (_, arg) = Genintern.generic_intern ist arg in
+    let arg = intern_genarg 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
+and intern_match_rule onlytac ist ?(as_type=false) = function
   | (All tc)::tl ->
-      All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist tl)
+      All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist ~as_type 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 lfun',metas1,hyps = intern_match_goal_hyps ist ~as_type lfun rl in
+      let ido,metas2,pat = intern_pattern ist ~as_type 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)
+      Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist ~as_type 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))
+and intern_genarg ist (GenArg (Rawwit wit, x)) =
+  match wit with
+  | ListArg wit ->
+      let map x =
+        let ans = intern_genarg ist (in_gen (rawwit wit) x) in
+        out_gen (glbwit wit) ans
       in
-      list_unpack { list_unpacker } x
-  | OptArgType _ ->
-      let opt_unpacker wit o = match raw o with
+      in_gen (glbwit (wit_list wit)) (List.map map x)
+  | OptArg wit ->
+      let ans = match x 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)
+      ans
+  | PairArg (wit1, wit2) ->
+      let p, q = x 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)
+  | ExtraArg s ->
+      snd (Genintern.generic_intern ist (in_gen (rawwit wit) x))
 
 (** Other entry points *)
 
@@ -852,13 +774,26 @@ let () =
   in
   Genintern.register_intern0 wit_clause_dft_concl intern_clause
 
+let intern_ident' ist id =
+  let lf = ref Id.Set.empty in
+  (ist, intern_ident lf ist id)
+
 let () =
+  Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var);
   Genintern.register_intern0 wit_ref (lift intern_global_reference);
+  Genintern.register_intern0 wit_ident intern_ident';
+  Genintern.register_intern0 wit_var (lift intern_hyp);
   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))
+  Genintern.register_intern0 wit_ltac (lift intern_tactic_or_tacarg);
+  Genintern.register_intern0 wit_quant_hyp (lift intern_quantified_hypothesis);
+  Genintern.register_intern0 wit_constr (fun ist c -> (ist,intern_constr ist c));
+  Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c));
+  Genintern.register_intern0 wit_open_constr (fun ist c -> (ist,intern_constr ist c));
+  Genintern.register_intern0 wit_red_expr (lift intern_red_expr);
+  Genintern.register_intern0 wit_bindings (lift intern_bindings);
+  Genintern.register_intern0 wit_constr_with_bindings (lift intern_constr_with_bindings);
+  Genintern.register_intern0 wit_destruction_arg (lift intern_destruction_arg);
+  ()
 
 (***************************************************************************)
 (* Backwarding recursive needs of tactic glob/interp/eval functions *)
diff --git a/tactics/tacintern.mli b/ltac/tacintern.mli
index 7901cfeb..71ca354f 100644
--- a/tactics/tacintern.mli
+++ b/ltac/tacintern.mli
@@ -12,7 +12,6 @@ open Tacexpr
 open Genarg
 open Constrexpr
 open Misctypes
-open Nametab
 
 (** Globalization of tactic expressions :
     Conversion from [raw_tactic_expr] to [glob_tactic_expr] *)
diff --git a/tactics/tacinterp.ml b/ltac/tacinterp.ml
index 54adbd93..20dbc2be 100644
--- a/tactics/tacinterp.ml
+++ b/ltac/tacinterp.ml
@@ -13,7 +13,7 @@ open Genredexpr
 open Glob_term
 open Glob_ops
 open Tacred
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
@@ -21,48 +21,86 @@ open Libnames
 open Globnames
 open Nametab
 open Pfedit
-open Proof_type
 open Refiner
-open Tacmach
+open Tacmach.New
 open Tactic_debug
 open Constrexpr
 open Term
 open Termops
 open Tacexpr
 open Genarg
+open Geninterp
 open Stdarg
 open Constrarg
 open Printer
 open Pretyping
-module Monad_ = Monad
-open Evd
 open Misctypes
 open Locus
 open Tacintern
 open Taccoerce
+open Sigma.Notations
 open Proofview.Notations
+open Context.Named.Declaration
+
+let ltac_trace_info = Tactic_debug.ltac_trace_info
+
+let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit ->
+  let Val.Dyn (t, _) = v in
+  let t' = match val_tag wit with
+  | Val.Base t' -> t'
+  | _ -> assert false (** not used in this module *)
+  in
+  match Val.eq t t' with
+  | None -> false
+  | Some Refl -> true
+
+let prj : type a. a Val.typ -> Val.t -> a option = fun t v ->
+  let Val.Dyn (t', x) = v in
+  match Val.eq t t' with
+  | None -> None
+  | Some Refl -> Some x
+
+let in_list tag v =
+  let tag = match tag with Val.Base tag -> tag | _ -> assert false in
+  Val.Dyn (Val.typ_list, List.map (fun x -> Val.Dyn (tag, x)) v)
+let in_gen wit v =
+  let t = match val_tag wit with
+  | Val.Base t -> t
+  | _ -> assert false (** not used in this module *)
+  in
+  Val.Dyn (t, v)
+let out_gen wit v =
+  let t = match val_tag wit with
+  | Val.Base t -> t
+  | _ -> assert false (** not used in this module *)
+  in
+  match prj t v with None -> assert false | Some x -> x
+
+let val_tag wit = val_tag (topwit wit)
+
+let pr_argument_type arg =
+  let Val.Dyn (tag, _) = arg in
+  Val.pr tag
 
 let safe_msgnl s =
   Proofview.NonLogical.catch
     (Proofview.NonLogical.print_debug (s++fnl()))
     (fun _ -> Proofview.NonLogical.print_warning (str "bug in the debugger: an exception is raised while printing debug information"++fnl()))
 
-type value = tlevel generic_argument
+type value = Val.t
 
 (** 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
+  | GlbAppl of (Names.kernel_name * Val.t 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 Val.Dyn (tag, _) = arg in
+    str"<" ++ Val.pr tag ++ str ":(" ++ Pptactic.pr_value Pptactic.ltop arg ++ str ")>"
 let pr_appl h vs =
   Pptactic.pr_ltac_constant  h ++ spc () ++
   Pp.prlist_with_sep spc pr_generic vs
@@ -85,8 +123,10 @@ type tacvalue =
       Id.t option list * glob_tactic_expr
   | VRec of value Id.Map.t ref * glob_tactic_expr
 
-let (wit_tacvalue : (Empty.t, Empty.t, tacvalue) Genarg.genarg_type) =
-  Genarg.create_arg None "tacvalue"
+let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) =
+  let wit = Genarg.create_arg "tacvalue" in
+  let () = register_val0 wit None in
+  wit
 
 let of_tacvalue v = in_gen (topwit wit_tacvalue) v
 let to_tacvalue v = out_gen (topwit wit_tacvalue) v
@@ -124,8 +164,43 @@ module Value = struct
     let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in
     of_tacvalue closure
 
+  let cast_error wit v =
+    let pr_v = Pptactic.pr_value Pptactic.ltop v in
+    let Val.Dyn (tag, _) = v in
+    let tag = Val.pr tag in
+    errorlabstrm "" (str "Type error: value " ++ pr_v ++ str " is a " ++ tag
+      ++ str " while type " ++ Val.pr wit ++ str " was expected.")
+
+  let unbox wit v ans = match ans with
+  | None -> cast_error wit v
+  | Some x -> x
+
+  let rec prj : type a. a Val.tag -> Val.t -> a = fun tag v -> match tag with
+  | Val.List tag -> List.map (fun v -> prj tag v) (unbox Val.typ_list v (to_list v))
+  | Val.Opt tag -> Option.map (fun v -> prj tag v) (unbox Val.typ_opt v (to_option v))
+  | Val.Pair (tag1, tag2) ->
+    let (x, y) = unbox Val.typ_pair v (to_pair v) in
+    (prj tag1 x, prj tag2 y)
+  | Val.Base t ->
+    let Val.Dyn (t', x) = v in
+    match Val.eq t t' with
+    | None -> cast_error t v
+    | Some Refl -> x
+
+  let rec tag_of_arg : type a b c. (a, b, c) genarg_type -> c Val.tag = fun wit -> match wit with
+  | ExtraArg _ -> val_tag wit
+  | ListArg t -> Val.List (tag_of_arg t)
+  | OptArg t -> Val.Opt (tag_of_arg t)
+  | PairArg (t1, t2) -> Val.Pair (tag_of_arg t1, tag_of_arg t2)
+
+  let val_cast arg v = prj (tag_of_arg arg) v
+
+  let cast (Topwit wit) v = val_cast wit v
+
 end
 
+let print_top_val env v = Pptactic.pr_value Pptactic.ltop v
+
 let dloc = Loc.ghost
 
 let catching_error call_trace fail (e, info) =
@@ -134,7 +209,7 @@ let catching_error call_trace fail (e, 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 *)
+    assert (CErrors.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
@@ -142,8 +217,8 @@ let catching_error call_trace fail (e, info) =
 
 let catch_error call_trace f x =
   try f x
-  with e when Errors.noncritical e ->
-    let e = Errors.push e in
+  with e when CErrors.noncritical e ->
+    let e = CErrors.push e in
     catching_error call_trace iraise e
 
 let catch_error_tac call_trace tac =
@@ -177,13 +252,13 @@ let pr_value env v =
     | Some (env,sigma) -> pr_lconstr_under_binders_env env sigma c
     | _ -> str "a term"
   else
-    str "a value of type" ++ spc () ++ pr_argument_type (genarg_tag v)
+    str "a value of type" ++ spc () ++ pr_argument_type 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
+    let arg = pr_argument_type 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
@@ -200,7 +275,7 @@ let pr_inspect env expr result =
     | VRec (ist, body) ->
       str "a recursive closure" ++ fnl () ++ pr_closure env !ist body
     else
-      let pp_type = pr_argument_type (genarg_tag result) in
+      let pp_type = pr_argument_type result in
       str "an object of type" ++ spc () ++ pp_type
   in
   pp_expr ++ fnl() ++ str "this is " ++ pp_result
@@ -209,22 +284,12 @@ let pr_inspect env expr result =
 let constr_of_id env id =
   Term.mkVar (let _ = Environ.lookup_named id env in id)
 
-(* 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 ((value_in : value -> Dyn.t),
-     (value_out : Dyn.t -> value)) = Dyn.create "value"
-
-let valueIn t = TacDynamic (Loc.ghost, value_in t)
-
 (** Generic arguments : table of interpretation functions *)
 
+(* Some of the code further down depends on the fact that push_trace does not modify sigma (the evar map) *)
 let push_trace call ist = match TacStore.get ist.extra f_trace with
-| None -> [call]
-| Some trace -> call :: trace
+| None -> Proofview.tclUNIT [call]
+| Some trace -> Proofview.tclUNIT (call :: trace)
 
 let propagate_trace ist loc id v =
   let v = Value.normalize v in
@@ -233,10 +298,11 @@ let propagate_trace ist loc id v =
     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
+        push_trace(loc,LtacVarCall (id,t)) ist >>= fun trace ->
+        let ans = VFun (appl,trace,lfun,it,b) in
+        Proofview.tclUNIT (of_tacvalue ans)
+    | _ ->  Proofview.tclUNIT v
+  else Proofview.tclUNIT v
 
 let append_trace trace v =
   let v = Value.normalize v in
@@ -260,9 +326,9 @@ let coerce_to_tactic loc id v =
     | _ -> fail ()
   else fail ()
 
+let intro_pattern_of_ident id = (Loc.ghost, IntroNaming (IntroIdentifier id))
 let value_of_ident id =
-  in_gen (topwit wit_intro_pattern)
-    (Loc.ghost, IntroNaming (IntroIdentifier id))
+  in_gen (topwit wit_intro_pattern) (intro_pattern_of_ident id)
 
 let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2
 
@@ -302,7 +368,7 @@ let debugging_exception_step ist signal_anomaly e pp =
     if signal_anomaly then explain_logic_error
     else explain_logic_error_no_anomaly in
   debugging_step ist (fun () ->
-    pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ !explain_exc e)
+    pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ explain_exc e)
 
 let error_ltac_variable loc id env v s =
    user_err_loc (loc, "", str "Ltac variable " ++ pr_id id ++
@@ -319,7 +385,7 @@ let interp_ltac_var coerce ist env locid =
   with Not_found -> anomaly (str "Detected '" ++ Id.print (snd locid) ++ str "' as ltac var at interning time")
 
 let interp_ident ist env sigma id =
-  try try_interp_ltac_var (coerce_to_ident false env) ist (Some (env,sigma)) (dloc,id)
+  try try_interp_ltac_var (coerce_var_to_ident false env) ist (Some (env,sigma)) (dloc,id)
   with Not_found -> id
 
 let pf_interp_ident id gl = interp_ident id (pf_env gl) (project gl)
@@ -337,10 +403,6 @@ 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)
-  with Not_found -> s
-
 let interp_int ist locid =
   try try_interp_ltac_var coerce_to_int ist None locid
   with Not_found ->
@@ -388,14 +450,13 @@ let interp_reference ist env sigma = function
     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
+        VarRef (get_id (Environ.lookup_named id env))
       with Not_found -> error_global_not_found_loc loc (qualid_of_ident id)
 
 let try_interp_evaluable env (loc, id) =
   let v = Environ.lookup_named id env in
   match v with
-  | (_, Some _, _) -> EvalVarRef id
+  | LocalDef _ -> EvalVarRef id
   | _ -> error_not_evaluable (VarRef id)
 
 let interp_evaluable ist env sigma = function
@@ -455,7 +516,9 @@ let extract_ltac_constr_values ist env =
 (* Extract the identifier list from lfun: join all branches (what to do else?)*)
 let rec intropattern_ids (loc,pat) = match pat with
   | IntroNaming (IntroIdentifier id) -> [id]
-  | IntroAction (IntroOrAndPattern ll) ->
+  | IntroAction (IntroOrAndPattern (IntroAndPattern l)) ->
+      List.flatten (List.map intropattern_ids l)
+  | IntroAction (IntroOrAndPattern (IntroOrPattern ll)) ->
       List.flatten (List.map intropattern_ids (List.flatten ll))
   | IntroAction (IntroInjection l) ->
       List.flatten (List.map intropattern_ids l)
@@ -478,6 +541,10 @@ let extract_ids ids lfun =
 let default_fresh_id = Id.of_string "H"
 
 let interp_fresh_id ist env sigma l =
+  let extract_ident ist env sigma id =
+    try try_interp_ltac_var (coerce_to_ident_not_fresh sigma env)
+			    ist (Some (env,sigma)) (dloc,id)
+    with Not_found -> id in
   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 -> []
@@ -490,8 +557,8 @@ let interp_fresh_id ist env sigma l =
       let s =
 	String.concat "" (List.map (function
 	  | ArgArg s -> s
-	  | 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
+	  | ArgVar (_,id) -> Id.to_string (extract_ident ist env sigma id)) l) in
+      let s = if CLexer.is_keyword s then s^"0" else s in
       Id.of_string s in
   Tactics.fresh_id_in_env avoid id env
 
@@ -507,7 +574,7 @@ let extract_ltac_constr_context ist env =
     with CannotCoerceTo _ -> map
   in
   let add_ident id env v map =
-    try Id.Map.add id (coerce_to_ident false env v) map
+    try Id.Map.add id (coerce_var_to_ident false env v) map
     with CannotCoerceTo _ -> map
   in
   let fold id v {idents;typed;untyped} =
@@ -561,8 +628,13 @@ let interp_gen kind ist allow_patvar flags env sigma (c,ce) =
         match kind with OfType _ -> WithoutTypeConstraint | _ -> kind in
       intern_gen kind_for_intern ~allow_patvar ~ltacvars env c
   in
-  let trace =
-    push_trace (loc_of_glob_constr c,LtacConstrInterp (c,vars)) ist in
+  (* Jason Gross: To avoid unnecessary modifications to tacinterp, as
+      suggested by Arnaud Spiwack, we run push_trace immediately.  We do
+      this with the kludge of an empty proofview, and rely on the
+      invariant that running the tactic returned by push_trace does
+      not modify sigma. *)
+  let (_, dummy_proofview) = Proofview.init sigma [] in
+  let (trace,_,_,_) = Proofview.apply env (push_trace (loc_of_glob_constr c,LtacConstrInterp (c,vars)) ist) dummy_proofview in
   let (evd,c) =
     catch_error trace (understand_ltac flags env sigma vars kind) c
   in
@@ -574,7 +646,7 @@ let interp_gen kind ist allow_patvar flags env sigma (c,ce) =
 
 let constr_flags = {
   use_typeclasses = true;
-  use_unif_heuristics = true;
+  solve_unification_constraints = true;
   use_hook = Some solve_by_implicit_tactic;
   fail_evar = true;
   expand_evars = true }
@@ -589,21 +661,21 @@ let interp_type = interp_constr_gen IsType
 
 let open_constr_use_classes_flags = {
   use_typeclasses = true;
-  use_unif_heuristics = true;
+  solve_unification_constraints = 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;
+  solve_unification_constraints = 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;
+  solve_unification_constraints = true;
   use_hook = None;
   fail_evar = false;
   expand_evars = false }
@@ -618,26 +690,15 @@ let interp_open_constr ?(expected_type=WithoutTypeConstraint) ist =
 let interp_pure_open_constr ist =
   interp_gen WithoutTypeConstraint ist false pure_open_constr_flags
 
-let interp_typed_pattern ist env sigma (c,_) =
+let interp_typed_pattern ist env sigma (_,c,_) =
   let 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 (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 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
@@ -659,13 +720,9 @@ let interp_constr_list ist env sigma c =
 let interp_open_constr_list =
   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
-  List.map (fun lem -> (local_sigma,lem)) lems
-
 (* Interprets a type expression *)
-let pf_interp_type ist gl =
-  interp_type ist (pf_env gl) (project gl)
+let pf_interp_type ist env sigma =
+  interp_type ist env sigma
 
 (* Interprets a reduction expression *)
 let interp_unfold ist env sigma (occs,qid) =
@@ -733,14 +790,17 @@ let interp_may_eval f ist env sigma = function
   | ConstrEval (r,c) ->
       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)
+      let (redfun, _) = Redexpr.reduction_of_red_expr env redexp in
+      let sigma = Sigma.Unsafe.of_evar_map sigma in
+      let Sigma (c, sigma, _) = redfun.Reductionops.e_redfun env sigma c_interp in
+      (Sigma.to_evar_map sigma, c)
   | ConstrContext ((loc,s),c) ->
       (try
 	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
+	let c = Typing.e_solve_evars env evdref c in
 	!evdref , c
       with
 	| Not_found ->
@@ -753,7 +813,7 @@ let interp_may_eval f ist env sigma = function
      try
 	f ist env sigma c
      with reraise ->
-       let reraise = Errors.push reraise in
+       let reraise = CErrors.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. *)
@@ -767,7 +827,7 @@ let interp_constr_may_eval ist env sigma c =
     try
       interp_may_eval interp_constr ist env sigma c
     with reraise ->
-      let reraise = Errors.push reraise in
+      let reraise = CErrors.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. *)
@@ -785,43 +845,45 @@ let interp_constr_may_eval ist env sigma c =
 (** 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
+    Ftactic.nf_enter {enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (project 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
+    Ftactic.nf_enter { enter = begin fun gl ->
+      Ftactic.return (pr_constr_under_binders_env (pf_env gl) (project 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
+    let print env sigma c = pr_constr_env env sigma (fst (Tactics.run_delayed env Evd.empty c)) in
+    Ftactic.nf_enter { enter = begin fun gl ->
+      Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (project 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
+    Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (project 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.nf_enter { enter = begin fun gl ->
       Ftactic.return (pr_closed_glob_env (pf_env gl)
-                        (Proofview.Goal.sigma gl) c)
-    end
+                        (project gl) c)
+    end }
+  else if has_type v (topwit wit_var) then
+    let id = out_gen (topwit wit_var) v in
+    Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_id id) 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
+    let tag = pr_argument_type v in
     Ftactic.return (str "<" ++ tag ++ str ">") (** TODO *)
 
 let interp_message_token ist = function
@@ -838,11 +900,6 @@ let interp_message ist l =
   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
@@ -866,13 +923,22 @@ and interp_intro_pattern_action ist env sigma = function
       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_open_constr ist env sigma c in
+      let c = { delayed = fun env sigma ->
+        let sigma = Sigma.to_evar_map sigma in
+        let (sigma, c) = interp_open_constr ist env sigma c in
+        Sigma.Unsafe.of_pair (c, sigma)
+      } 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_or_and_intro_pattern ist env sigma = function
+  | IntroAndPattern l ->
+      let sigma, l = List.fold_map (interp_intro_pattern ist env) sigma l in
+      sigma, IntroAndPattern l
+  | IntroOrPattern ll ->
+      let sigma, ll = List.fold_map (interp_intro_pattern_list_as_list ist env) sigma ll in
+      sigma, IntroOrPattern ll
 
 and interp_intro_pattern_list_as_list ist env sigma = function
   | [loc,IntroNaming (IntroIdentifier id)] as l ->
@@ -947,19 +1013,11 @@ let interp_constr_with_bindings ist env sigma (c,bl) =
   let sigma, c = interp_open_constr ist env sigma c in
   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 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 -> Loc.ghost
 | ImplicitBindings l -> loc_of_glob_constr (fst (List.last l))
@@ -969,13 +1027,21 @@ 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 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
+  let f = { delayed = fun env sigma ->
+    let sigma = Sigma.to_evar_map sigma in
+    let (sigma, c) = interp_open_constr_with_bindings ist env sigma cb in
+    Sigma.Unsafe.of_pair (c, sigma)
+  } in
     (loc,f)
 
-let interp_induction_arg ist gl arg =
+let interp_destruction_arg ist gl arg =
   match arg with
   | keep,ElimOnConstr c ->
-      keep,ElimOnConstr (fun env sigma -> interp_constr_with_bindings ist env sigma c)
+      keep,ElimOnConstr { delayed = fun env sigma ->
+        let sigma = Sigma.to_evar_map sigma in
+        let (sigma, c) = interp_constr_with_bindings ist env sigma c in
+        Sigma.Unsafe.of_pair (c, sigma)
+      }
   | keep,ElimOnAnonHyp n as x -> x
   | keep,ElimOnIdent (loc,id) ->
       let error () = user_err_loc (loc, "",
@@ -985,11 +1051,13 @@ let interp_induction_arg ist gl arg =
       let try_cast_id id' =
         if Tactics.is_quantified_hypothesis id' gl
         then keep,ElimOnIdent (loc,id')
-        else keep, ElimOnConstr (fun env sigma ->
-          try sigma, (constr_of_id env id', NoBindings)
+        else
+          (keep, ElimOnConstr { delayed = begin fun env sigma ->
+          try Sigma.here (constr_of_id env id', NoBindings) sigma
           with Not_found ->
-            user_err_loc (loc, "interp_induction_arg",
-            pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared nor a quantified hypothesis."))
+            user_err_loc (loc, "interp_destruction_arg",
+            pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared nor a quantified hypothesis.")
+          end })
       in
       try
         (** FIXME: should be moved to taccoerce *)
@@ -1007,16 +1075,18 @@ let interp_induction_arg ist gl arg =
           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))
+        | Some c -> keep,ElimOnConstr { delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) }
       with Not_found ->
 	(* We were in non strict (interactive) mode *)
 	if Tactics.is_quantified_hypothesis id gl then
           keep,ElimOnIdent (loc,id)
 	else
           let c = (GVar (loc,id),Some (CRef (Ident (loc,id),None))) in
-          let f env sigma = 
+          let f = { delayed = fun env sigma ->
+            let sigma = Sigma.to_evar_map sigma in
             let (sigma,c) = interp_open_constr ist env sigma c in
-            sigma,(c,NoBindings) in
+            Sigma.Unsafe.of_pair ((c,NoBindings), sigma)
+          } in
           keep,ElimOnConstr f
 
 (* Associates variables with values and gives the remaining variables and
@@ -1040,12 +1110,11 @@ let interp_context ctxt = in_gen (topwit wit_constr_context) ctxt
 (* Reads a pattern by substituting vars of lfun *)
 let use_types = false
 
-let eval_pattern lfun ist env sigma ((glob,_),pat as c) =
-  let bound_names = bound_glob_vars glob in
+let eval_pattern lfun ist env sigma (bvars,(glob,_),pat as c) =
   if use_types then
-    (bound_names,interp_typed_pattern ist env sigma c)
+    (bvars,interp_typed_pattern ist env sigma c)
   else
-    (bound_names,instantiate_pattern env sigma lfun pat)
+    (bvars,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)
@@ -1078,23 +1147,15 @@ let rec read_match_rule lfun ist env sigma = function
       :: read_match_rule lfun ist env sigma tl
   | [] -> []
 
-
-(* misc *)
-
-let mk_constr_value ist gl c =
-  let (sigma,c_interp) = pf_interp_constr ist gl c in
-  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 pack_sigma (sigma,c) = {it=c;sigma=sigma;}
+let warn_deprecated_info =
+  CWarnings.create ~name:"deprecated-info-tactical" ~category:"deprecated"
+         (fun () ->
+          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_eauto.")
 
 (* Interprets an l-tac expression into a value *)
-let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : typed_generic_argument Ftactic.t =
+let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t 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
@@ -1121,14 +1182,16 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : typed_generi
           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
+	Tactic_debug.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) ->
       let call = LtacAtomCall t in
-      catch_error_tac (push_trace(loc,call) ist) (interp_atomic ist t)
+      push_trace(loc,call) ist >>= fun trace ->
+      Profile_ltac.do_profile "eval_tactic:2" trace
+        (catch_error_tac trace (interp_atomic ist t))
   | TacFun _ | TacLetIn _ -> assert false
   | TacMatchGoal _ | TacMatch _ -> assert false
   | TacId [] -> Proofview.tclLIFT (db_breakpoint (curr_debug ist) [])
@@ -1159,9 +1222,9 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with
            tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac))
          end
   | TacAbstract (tac,ido) ->
-      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
+      Proofview.Goal.nf_enter { enter = begin fun gl -> Tactics.tclABSTRACT
+        (Option.map (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 ->
@@ -1197,110 +1260,18 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with
   | TacComplete tac -> Tacticals.New.tclCOMPLETE (interp_tactic ist tac)
   | TacArg a -> interp_tactic ist (TacArg a)
   | TacInfo tac ->
-      msg_warning
-	(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_eauto.");
+      warn_deprecated_info ();
       eval_tactic ist tac
+  | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_tactic ist tac)
   (* 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_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_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 (ids, body) = Tacenv.interp_alias s 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 interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in
       let tac l =
-        let lfun = List.fold_right addvar l ist.lfun in
-        let trace = push_trace (loc,LtacNotationCall s) ist in
+        let addvar x v accu = Id.Map.add x v accu in
+        let lfun = List.fold_right2 addvar ids l ist.lfun in
+        Ftactic.lift (push_trace (loc,LtacNotationCall s) ist) >>= fun trace ->
         let ist = {
           lfun = lfun;
           extra = TacStore.set ist.extra f_trace trace; } in
@@ -1308,52 +1279,34 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with
         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)
+        Ftactic.with_env interp_vars >>= fun (env, lr) ->
+        let name () = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in
+        Proofview.Trace.name_tactic name (tac lr)
       (* 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
+      let tac =
+        let len1 = List.length ids in
+        let len2 = List.length l in
+        if len1 = len2 then tac
+        else Tacticals.New.tclZEROMSG (str "Arguments length mismatch: \
+          expected " ++ int len1 ++ str ", found " ++ int len2)
+      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
+      push_trace (loc,LtacMLCall tac) ist >>= fun trace ->
       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
+      let tac = Tacenv.interp_ml_tactic opn in
+      let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in
+      let tac args =
+        let name () = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in
+        Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist))
+      in
+      Ftactic.run args tac
 
-and force_vrec ist v : typed_generic_argument Ftactic.t =
+and force_vrec ist v : Val.t Ftactic.t =
   let v = Value.normalize v in
   if has_type v (topwit wit_tacvalue) then
     let v = to_tacvalue v in
@@ -1362,49 +1315,39 @@ and force_vrec ist v : typed_generic_argument Ftactic.t =
     | v -> Ftactic.return (of_tacvalue v)
   else Ftactic.return v
 
-and interp_ltac_reference loc' mustbetac ist r : typed_generic_argument Ftactic.t =
+and interp_ltac_reference loc' mustbetac ist r : Val.t Ftactic.t =
   match r with
   | ArgVar (loc,id) ->
       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
+      let open Ftactic in
+      force_vrec ist v >>= begin fun v ->
+      Ftactic.lift (propagate_trace ist loc id v) >>= fun 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.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 extra = TacStore.set ist.extra f_avoid_ids ids in
+      push_trace loc_info ist >>= fun trace ->
+      let extra = TacStore.set extra f_trace trace 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 =
+and interp_tacarg ist arg : Val.t 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
+  | TacGeneric arg -> interp_genarg ist arg
   | Reference r -> interp_ltac_reference dloc false ist r
   | ConstrMayEval c ->
-      Ftactic.enter begin fun gl ->
-        let sigma = Proofview.Goal.sigma gl in
+      Ftactic.s_enter { s_enter = begin fun gl ->
+        let sigma = project 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
+        Sigma.Unsafe.of_pair (Ftactic.return (Value.of_constr c_interp), sigma)
+      end }
   | TacCall (loc,r,[]) ->
       interp_ltac_reference loc true ist r
   | TacCall (loc,f,l) ->
@@ -1413,26 +1356,18 @@ and interp_tacarg ist arg : typed_generic_argument Ftactic.t =
       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.enter { enter = begin fun gl ->
+        let id = interp_fresh_id ist (pf_env gl) (project gl) l in
         Ftactic.return (in_gen (topwit wit_intro_pattern) (dloc, IntroNaming (IntroIdentifier id)))
-      end
+      end }
   | TacPretype c ->
-      Ftactic.enter begin fun gl ->
+      Ftactic.s_enter { s_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
+        let c = interp_uconstr ist env c in
+        let Sigma (c, sigma, p) = (type_uconstr ist c).delayed env sigma in
+        Sigma (Ftactic.return (Value.of_constr c), sigma, p)
+      end }
   | TacNumgoals ->
       Ftactic.lift begin
         let open Proofview.Notations in
@@ -1440,20 +1375,9 @@ and interp_tacarg ist arg : typed_generic_argument Ftactic.t =
         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 fv largs : typed_generic_argument Ftactic.t =
+and interp_app loc ist fv largs : Val.t Ftactic.t =
   let (>>=) = Ftactic.bind in
   let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in
   let fv = Value.normalize fv in
@@ -1506,11 +1430,11 @@ and tactic_of_value ist vle =
         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
+      Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac)
   | (VFun _|VRec _) -> Tacticals.New.tclZEROMSG (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
+    tactic_of_value ist tac
   else Tacticals.New.tclZEROMSG (str "Expression does not evaluate to a tactic.")
 
 (* Interprets the clauses of a recursive LetIn *)
@@ -1597,141 +1521,78 @@ and interp_match ist lz constr lmr =
           Proofview.tclZERO ~info e
     end
   end >>= fun constr ->
-  Ftactic.enter begin fun gl ->
-    let sigma = Proofview.Goal.sigma gl in
+  Ftactic.enter { enter = begin fun gl ->
+    let sigma = project 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
+  end }
 
 (* Interprets the Match Context expressions *)
 and interp_match_goal ist lz lr lmr =
-    Ftactic.nf_enter begin fun gl ->
-      let sigma = Proofview.Goal.sigma gl in
+    Ftactic.nf_enter { enter = begin fun gl ->
+      let sigma = project 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
+    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
-    | IntOrVarArgType ->
-      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_ident ist env sigma (out_gen (glbwit wit_ident) x))
-    | VarArgType ->
-      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) =
-        interp_constr ist env !evdref (out_gen (glbwit wit_constr) x)
-      in
-      evdref := sigma;
-      in_gen (topwit wit_constr) c_interp
-    | ConstrMayEvalArgType ->
-      let (sigma,c_interp) = interp_constr_may_eval ist env !evdref (out_gen (glbwit wit_constr_may_eval) x) in
-      evdref := sigma;
-      in_gen (topwit wit_constr_may_eval) c_interp
-    | QuantHypArgType ->
-      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) =
-        interp_red_expr ist env !evdref (out_gen (glbwit wit_red_expr) x)
-      in
-      evdref := sigma;
-      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 (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 (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
-    | 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
+and interp_genarg ist x : Val.t Ftactic.t =
+    let open Ftactic.Notations in
+    (** Ad-hoc handling of some types. *)
+    let tag = genarg_tag x in
+    if argument_type_eq tag (unquote (topwit (wit_list wit_var))) then
+      interp_genarg_var_list ist x
+    else if argument_type_eq tag (unquote (topwit (wit_list wit_constr))) then
+      interp_genarg_constr_list ist x
+    else
+    let GenArg (Glbwit wit, x) = x in
+    match wit with
+    | ListArg wit ->
+      let map x = interp_genarg ist (Genarg.in_gen (glbwit wit) x) in
+      Ftactic.List.map map x >>= fun l ->
+      Ftactic.return (Val.Dyn (Val.typ_list, l))
+    | OptArg wit ->
+      begin match x with
+      | None -> Ftactic.return (Val.Dyn (Val.typ_opt, 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 ->
-        let (sigma,v) = Geninterp.generic_interp ist { Evd.it=gl;sigma=(!evdref) } x in
-	evdref:=sigma;
-	v
-  in
-  let v = interp_genarg x in
-  !evdref , v
-
+        interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x ->
+        Ftactic.return (Val.Dyn (Val.typ_opt, Some x))
+      end
+    | PairArg (wit1, wit2) ->
+      let (p, q) = x in
+      interp_genarg ist (Genarg.in_gen (glbwit wit1) p) >>= fun p ->
+      interp_genarg ist (Genarg.in_gen (glbwit wit2) q) >>= fun q ->
+      Ftactic.return (Val.Dyn (Val.typ_pair, (p, q)))
+    | ExtraArg s ->
+      Geninterp.interp wit ist x
 
 (** returns [true] for genargs which have the same meaning
     independently of goals. *)
 
-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_constr_list ist env sigma x =
-  let lc = out_gen (glbwit (wit_list wit_constr)) x in
+and interp_genarg_constr_list ist x =
+  Ftactic.nf_s_enter { s_enter = begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in
+  let lc = Genarg.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
+  let lc = in_list (val_tag wit_constr) lc in
+  Sigma.Unsafe.of_pair (Ftactic.return lc, sigma)
+  end }
 
-and interp_genarg_var_list ist env sigma x =
-  let lc = out_gen (glbwit (wit_list wit_var)) x in
+and interp_genarg_var_list ist x =
+  Ftactic.enter { enter = begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in
+  let lc = Genarg.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
+  let lc = in_list (val_tag wit_var) lc in
+  Ftactic.return lc
+  end }
 
 (* Interprets tactic expressions : returns a "constr" *)
 and interp_ltac_constr ist e : constr Ftactic.t =
@@ -1740,7 +1601,7 @@ and interp_ltac_constr ist e : constr Ftactic.t =
       (val_interp ist e)
       begin function (err, info) -> match err with
         | Not_found ->
-            Ftactic.enter begin fun gl ->
+            Ftactic.enter { enter = begin fun gl ->
               let env = Proofview.Goal.env gl in
               Proofview.tclLIFT begin
                 debugging_step ist (fun () ->
@@ -1748,13 +1609,13 @@ and interp_ltac_constr ist e : constr Ftactic.t =
                     Pptactic.pr_glob_tactic env e)
               end
             <*> Proofview.tclZERO Not_found
-            end
+            end }
         | err -> Proofview.tclZERO ~info err
       end
   end >>= fun result ->
-  Ftactic.enter begin fun gl ->
+  Ftactic.enter { enter = begin fun gl ->
   let env = Proofview.Goal.env gl in
-  let sigma = Proofview.Goal.sigma gl in
+  let sigma = project gl in
   let result = Value.normalize result in
   try
     let cresult = coerce_to_closed_constr env result in
@@ -1769,7 +1630,7 @@ and interp_ltac_constr ist e : constr Ftactic.t =
     let env = Proofview.Goal.env gl in
     Tacticals.New.tclZEROMSG (str "Must evaluate to a closed term" ++ fnl() ++
       str "offending expression: " ++ fnl() ++ pr_inspect env e result)
-  end
+  end }
 
 
 (* Interprets tactic expressions : returns a "tactic" *)
@@ -1782,52 +1643,31 @@ and name_atomic ?env tacexpr tac : unit Proofview.tactic =
   | Some e -> Proofview.tclUNIT e
   | None -> Proofview.tclENV
   end >>= fun env ->
-  let name () = Pptactic.pr_tactic env (TacAtom (Loc.ghost,tacexpr)) in
+  let name () = Pptactic.pr_atomic_tactic env tacexpr in
   Proofview.Trace.name_tactic name tac
 
 (* Interprets a primitive tactic *)
 and interp_atomic ist tac : unit Proofview.tactic =
   match tac with
   (* Basic tactics *)
-  | TacIntroPattern l ->
-      Proofview.Goal.enter begin fun gl ->
+  | TacIntroPattern (ev,l) ->
+      Proofview.Goal.enter { enter = begin fun gl ->
         let env = Proofview.Goal.env gl in
-        let sigma = Proofview.Goal.sigma gl in
+        let sigma = project gl in
         let sigma,l' = interp_intro_pattern_list_as_list ist env sigma l in
-        Tacticals.New.tclWITHHOLES false 
+        Tacticals.New.tclWITHHOLES ev
         (name_atomic ~env
-          (TacIntroPattern l)
+          (TacIntroPattern (ev,l))
           (* spiwack: print uninterpreted, not sure if it is the
              expected behaviour. *)
-          (Tactics.intros_patterns l')) sigma
-      end
-  | TacIntroMove (ido,hto) ->
-      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_ident ist env sigma) ido in
-        name_atomic ~env
-          (TacIntroMove(ido,mloc))
-          (Tactics.intro_move ido mloc)
-      end
-  | TacExact c ->
-      (* 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
+          (Tactics.intro_patterns ev l')) sigma
+      end }
   | TacApply (a,ev,cb,cl) ->
       (* spiwack: until the tactic is in the monad *)
       Proofview.Trace.name_tactic (fun () -> Pp.str"<apply>") begin
-      Proofview.Goal.enter begin fun gl ->
+      Proofview.Goal.enter { enter = begin fun gl ->
         let env = Proofview.Goal.env gl in
-        let sigma = Proofview.Goal.sigma gl in
+        let sigma = project 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 
@@ -1838,12 +1678,12 @@ and interp_atomic ist tac : unit Proofview.tactic =
               let sigma,(id,cl) = interp_in_hyp_as ist env sigma cl in
               sigma, Tactics.apply_delayed_in a ev id l cl in
         Tacticals.New.tclWITHHOLES ev tac sigma
-      end
+      end }
       end
   | TacElim (ev,(keep,cb),cbo) ->
-      Proofview.Goal.enter begin fun gl ->
+      Proofview.Goal.enter { enter = begin fun gl ->
         let env = Proofview.Goal.env gl in
-        let sigma = Proofview.Goal.sigma gl in 
+        let sigma = project 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 =
@@ -1851,10 +1691,10 @@ and interp_atomic ist tac : unit Proofview.tactic =
           name_atomic ~env (TacElim (ev,(keep,cb),cbo)) tac
         in
         Tacticals.New.tclWITHHOLES ev named_tac sigma
-      end
+      end }
   | TacCase (ev,(keep,cb)) ->
-      Proofview.Goal.enter begin fun gl ->
-        let sigma = Proofview.Goal.sigma gl in
+      Proofview.Goal.enter { enter = begin fun gl ->
+        let sigma = project gl in
         let env = Proofview.Goal.env gl in
         let sigma, cb = interp_constr_with_bindings ist env sigma cb in
         let named_tac =
@@ -1862,101 +1702,71 @@ and interp_atomic ist tac : unit Proofview.tactic =
           name_atomic ~env (TacCase(ev,(keep,cb))) tac
         in
         Tacticals.New.tclWITHHOLES ev named_tac sigma
-      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_ident ist env sigma) idopt in
-        name_atomic ~env
-          (TacFix(idopt,n))
-          (Proofview.V82.tactic (Tactics.fix idopt n))
-      end
+      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 ->
+      Proofview.Goal.nf_s_enter { s_enter = 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
+          let (sigma,c_interp) = pf_interp_type ist env sigma c in
 	  sigma , (interp_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_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_ident ist env sigma) idopt in
-        name_atomic ~env
-          (TacCofix (idopt))
-          (Proofview.V82.tactic (Tactics.cofix idopt))
+        let tac = Tactics.mutual_fix (interp_ident ist env sigma id) n l_interp 0 in
+        Sigma.Unsafe.of_pair (tac, sigma)
+      end }
       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 ->
+      Proofview.Goal.nf_s_enter { s_enter = 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
+	  let (sigma,c_interp) = pf_interp_type ist env sigma c in
 	  sigma , (interp_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_ident ist env sigma id) l_interp 0)
-          gl
-      end
+        let tac = Tactics.mutual_cofix (interp_ident ist env sigma id) l_interp 0 in
+        Sigma.Unsafe.of_pair (tac, sigma)
+      end }
       end
   | TacAssert (b,t,ipat,c) ->
-      Proofview.Goal.enter begin fun gl ->
+      Proofview.Goal.enter { enter = begin fun gl ->
         let env = Proofview.Goal.env gl in
-        let sigma = Proofview.Goal.sigma gl in
+        let sigma = project 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
+        let tac = Option.map (Option.map (interp_tactic ist)) t in
         Tacticals.New.tclWITHHOLES false
         (name_atomic ~env
-          (TacAssert(b,t,ipat,c))
+          (TacAssert(b,Option.map (Option.map ignore) t,ipat,c))
           (Tactics.forward b tac ipat' c)) sigma
-      end
+      end }
   | TacGeneralize cl ->
-      Proofview.Goal.enter begin fun gl ->
-        let sigma = Proofview.Goal.sigma gl in
+      Proofview.Goal.enter { enter = begin fun gl ->
+        let sigma = project 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
         Tacticals.New.tclWITHHOLES false
         (name_atomic ~env
           (TacGeneralize cl)
-          (Proofview.V82.tactic (Tactics.Simple.generalize_gen cl))) sigma
-      end
-  | TacGeneralizeDep c ->
-      (new_interp_constr ist c) (fun c ->
-        name_atomic (* spiwack: probably needs a goal environment *)
-        (TacGeneralizeDep c)
-        (Proofview.V82.tactic (Tactics.generalize_dep c))
-       )
+          (Tactics.generalize_gen cl)) sigma
+      end }
   | TacLetTac (na,c,clp,b,eqpat) ->
       Proofview.V82.nf_evar_goals <*>
-      Proofview.Goal.nf_enter begin fun gl ->
+      Proofview.Goal.nf_enter { enter = begin fun gl ->
         let env = Proofview.Goal.env gl in
-        let sigma = Proofview.Goal.sigma gl in
+        let sigma = project 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) =
-            Tacmach.New.of_old (fun gl -> pf_interp_constr ist gl c) gl
-          in
+          let (sigma,c_interp) = pf_interp_constr ist gl c 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
@@ -1980,58 +1790,22 @@ and interp_atomic ist tac : unit Proofview.tactic =
 	    (Tacticals.New.tclWITHHOLES false (*in hope of a future "eset/epose"*)
                (let_pat_tac b (interp_name ist env sigma na)
                   ((sigma,sigma'),c) clp eqpat) sigma')
-      end
-
-  (* Automation tactics *)
-  | TacTrivial (debug,lems,l) ->
-      begin if debug == Tacexpr.Info then
-          msg_warning
-	    (strbrk"The \"info_trivial\" tactic" ++ spc ()
-           ++strbrk"does not print traces anymore." ++ spc()
-           ++strbrk"Use \"Info 1 trivial\", instead.")
-      end;
-      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) ->
-      begin if debug == Tacexpr.Info then
-          msg_warning
-	    (strbrk"The \"info_auto\" tactic" ++ spc ()
-           ++strbrk"does not print traces anymore." ++ spc()
-           ++strbrk"Use \"Info 1 auto\", instead.")
-      end;
-      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
+      end }
 
   (* Derived basic tactics *)
   | 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 ->
+      Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
         let env = Proofview.Goal.env gl in
-        let sigma = Proofview.Goal.sigma gl in
+        let sigma = project 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 c = interp_destruction_arg ist gl c 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
@@ -2042,88 +1816,24 @@ and interp_atomic ist tac : unit Proofview.tactic =
         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
+        let tac = 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
-      name_atomic
-        (TacDoubleInduction (h1,h2))
-        (Elim.h_double_induction h1 h2)
-  (* Context management *)
-  | 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 ->
-      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_ident ist env sigma (snd id2)) l
+            (Tactics.induction_destruct isrec ev (l,el))
         in
-        name_atomic ~env
-          (TacRename l)
-          (Tactics.rename_hyp l)
-      end
+        Sigma.Unsafe.of_pair (tac, sigma)
+      end }
 
-  (* Constructors *)
-  | 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 =
-          let tac = Tactics.split_with_bindings ev bll in
-          name_atomic ~env (TacSplit (ev, bll)) tac
-        in
-        Tacticals.New.tclWITHHOLES ev named_tac sigma
-      end
   (* Conversion *)
   | TacReduce (r,cl) ->
-      (* spiwack: until the tactic is in the monad *)
-      Proofview.Trace.name_tactic (fun () -> Pp.str"<reduce>") begin
-      Proofview.V82.tactic begin fun gl -> 
+      Proofview.Goal.nf_s_enter { s_enter = 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
+        Sigma.Unsafe.of_pair (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl), sigma)
+      end }
   | TacChange (None,c,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 ->
+      Proofview.Goal.nf_enter { enter = begin fun gl ->
         let is_onhyps = match cl.onhyps with
           | None | Some [] -> true
           | _ -> false
@@ -2132,84 +1842,79 @@ and interp_atomic ist tac : unit Proofview.tactic =
           | AllOccurrences | NoOccurrences -> true
           | _ -> false
         in
-        let c_interp patvars sigma =
+        let c_interp patvars = { Sigma.run = begin fun sigma ->
 	  let lfun' = Id.Map.fold (fun id c lfun ->
 	    Id.Map.add id (Value.of_constr c) lfun) 
 	    patvars ist.lfun
 	  in
+	  let sigma = Sigma.to_evar_map sigma in
 	  let ist = { ist with lfun = lfun' } in
-	  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
+	  let (sigma, c) =
+            if is_onhyps && is_onconcl
+            then interp_type ist (pf_env gl) sigma c
+            else interp_constr ist (pf_env gl) sigma c
+          in
+          Sigma.Unsafe.of_pair (c, sigma)
+        end } in
+        Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl)
+      end }
       end
   | TacChange (Some op,c,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 ->
+      Proofview.Goal.enter { 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 op = interp_typed_pattern ist env sigma op in
-          let to_catch = function Not_found -> true | e -> Errors.is_anomaly e in
-          let c_interp patvars sigma =
-	    let lfun' = Id.Map.fold (fun id c lfun ->
-	      Id.Map.add id (Value.of_constr c) lfun) 
-	      patvars ist.lfun
-	    in
-	    let ist = { ist with lfun = lfun' } in
-	      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.")
+        let sigma = project gl in
+        let op = interp_typed_pattern ist env sigma op in
+        let to_catch = function Not_found -> true | e -> CErrors.is_anomaly e in
+        let c_interp patvars = { Sigma.run = begin fun sigma ->
+          let lfun' = Id.Map.fold (fun id c lfun ->
+            Id.Map.add id (Value.of_constr c) lfun) 
+            patvars ist.lfun
           in
-	    (Tactics.change (Some op) c_interp (interp_clause ist env sigma cl))
-	      gl
-        end
-      end
+          let ist = { ist with lfun = lfun' } in
+            try
+              let sigma = Sigma.to_evar_map sigma in
+              let (sigma, c) = interp_constr ist env sigma c in
+              Sigma.Unsafe.of_pair (c, sigma)
+            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.")
+        end } in
+        Tactics.change (Some op) c_interp (interp_clause ist env sigma cl)
+      end }
       end
 
-  (* Equivalence relations *)
-  | 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) ->
-      Proofview.Goal.enter begin fun gl ->
+      Proofview.Goal.enter { 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
+          let f = { delayed = fun env sigma ->
+            let sigma = Sigma.to_evar_map sigma in
+            let (sigma, c) = interp_open_constr_with_bindings ist env sigma c in
+            Sigma.Unsafe.of_pair (c, sigma)
+          } in
 	  (b,m,keep,f)) l in
         let env = Proofview.Goal.env gl in
-        let sigma = Proofview.Goal.sigma gl in
+        let sigma = project gl in
         let cl = interp_clause ist env sigma cl in
         name_atomic ~env
-          (TacRewrite (ev,l,cl,by))
+          (TacRewrite (ev,l,cl,Option.map ignore by))
           (Equality.general_multi_rewrite ev l' cl
              (Option.map (fun by -> Tacticals.New.tclCOMPLETE (interp_tactic ist by),
                Equality.Naive)
                 by))
-      end
+      end }
   | TacInversion (DepInversion (k,c,ids),hyp) ->
-      Proofview.Goal.nf_enter begin fun gl ->
+      Proofview.Goal.nf_enter { enter = begin fun gl ->
         let env = Proofview.Goal.env gl in
-        let sigma = Proofview.Goal.sigma gl in
+        let sigma = project 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
+              let (sigma,c_interp) = pf_interp_constr ist gl c in
               sigma , Some c_interp
         in
         let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in
@@ -2218,11 +1923,11 @@ and interp_atomic ist tac : unit Proofview.tactic =
         (name_atomic ~env
           (TacInversion(DepInversion(k,c_interp,ids),dqhyps))
           (Inv.dinv k c_interp ids_interp dqhyps)) sigma
-      end
+      end }
   | TacInversion (NonDepInversion (k,idl,ids),hyp) ->
-      Proofview.Goal.enter begin fun gl ->
+      Proofview.Goal.enter { enter = begin fun gl ->
         let env = Proofview.Goal.env gl in
-        let sigma = Proofview.Goal.sigma gl in
+        let sigma = project 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
@@ -2230,19 +1935,20 @@ and interp_atomic ist tac : unit Proofview.tactic =
         (name_atomic ~env
           (TacInversion (NonDepInversion (k,hyps,ids),dqhyps))
           (Inv.inv_clause k ids_interp hyps dqhyps)) sigma
-      end
+      end }
   | TacInversion (InversionUsing (c,idl),hyp) ->
-      Proofview.Goal.enter begin fun gl ->
+      Proofview.Goal.s_enter { s_enter = begin fun gl ->
         let env = Proofview.Goal.env gl in
-        let sigma = Proofview.Goal.sigma gl in
+        let sigma = project 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
+        let tac = name_atomic ~env
           (TacInversion (InversionUsing (c_interp,hyps),dqhyps))
           (Leminv.lemInv_clause dqhyps c_interp hyps)
-      end
+        in
+        Sigma.Unsafe.of_pair (tac, sigma)
+      end }
 
 (* Initial call for interpretation *)
 
@@ -2263,7 +1969,7 @@ let eval_tactic_ist ist t =
 
 
 let interp_tac_gen lfun avoid_ids debug t =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { 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
@@ -2272,7 +1978,7 @@ let interp_tac_gen lfun avoid_ids debug t =
   interp_tactic ist
     (intern_pure_tactic {
       ltacvars; genv = env } t)
-  end
+  end }
 
 let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t
 let _ = Proof_global.set_interp_tac interp
@@ -2292,21 +1998,28 @@ let hide_interp global t ot =
     Proofview.tclENV >>= fun env ->
     hide_interp env
   else
-    Proofview.Goal.enter begin fun gl ->
+    Proofview.Goal.enter { enter = begin fun gl ->
       hide_interp (Proofview.Goal.env gl)
-    end
+    end }
 
 (***************************************************************************)
 (** Register standard arguments *)
 
+let register_interp0 wit f =
+  let open Ftactic.Notations in
+  let interp ist v =
+    f ist v >>= fun v -> Ftactic.return (Val.inject (val_tag wit) v)
+  in
+  Geninterp.register_interp0 wit interp
+
 let def_intern ist x = (ist, x)
 let def_subst _ x = x
-let def_interp ist gl x = (project gl, x)
+let def_interp ist x = Ftactic.return x
 
 let declare_uniform t =
   Genintern.register_intern0 t def_intern;
   Genintern.register_subst0 t def_subst;
-  Geninterp.register_interp0 t def_interp
+  register_interp0 t def_interp
 
 let () =
   declare_uniform wit_unit
@@ -2323,27 +2036,62 @@ let () =
 let () =
   declare_uniform wit_pre_ident
 
+let lift f = (); fun ist x -> Ftactic.enter { enter = begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in
+  Ftactic.return (f ist env sigma x)
+end }
+
+let lifts f = (); fun ist x -> Ftactic.nf_s_enter { s_enter = begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in
+  let (sigma, v) = f ist env sigma x in
+  Sigma.Unsafe.of_pair (Ftactic.return v, sigma)
+end }
+
+let interp_bindings' ist bl = Ftactic.return { delayed = fun env sigma ->
+  let (sigma, bl) = interp_bindings ist env (Sigma.to_evar_map sigma) bl in
+  Sigma.Unsafe.of_pair (bl, sigma)
+  }
+
+let interp_constr_with_bindings' ist c = Ftactic.return { delayed = fun env sigma ->
+  let (sigma, c) = interp_constr_with_bindings ist env (Sigma.to_evar_map sigma) c in
+  Sigma.Unsafe.of_pair (c, sigma)
+  }
+
+let interp_destruction_arg' ist c = Ftactic.nf_enter { enter = begin fun gl ->
+  Ftactic.return (interp_destruction_arg ist gl c)
+end }
+
 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
+  register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n));
+  register_interp0 wit_ref (lift interp_reference);
+  register_interp0 wit_ident (lift interp_ident);
+  register_interp0 wit_var (lift interp_hyp);
+  register_interp0 wit_intro_pattern (lifts interp_intro_pattern);
+  register_interp0 wit_clause_dft_concl (lift interp_clause);
+  register_interp0 wit_constr (lifts interp_constr);
+  register_interp0 wit_tacvalue (fun ist v -> Ftactic.return v);
+  register_interp0 wit_red_expr (lifts interp_red_expr);
+  register_interp0 wit_quant_hyp (lift interp_declared_or_quantified_hypothesis);
+  register_interp0 wit_open_constr (lifts interp_open_constr);
+  register_interp0 wit_bindings interp_bindings';
+  register_interp0 wit_constr_with_bindings interp_constr_with_bindings';
+  register_interp0 wit_destruction_arg interp_destruction_arg';
+  ()
 
 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
+  let interp ist tac = Ftactic.return (Value.of_closure ist tac) in
+  register_interp0 wit_tactic interp
 
 let () =
-  Geninterp.register_interp0 wit_uconstr (fun ist gl c ->
-     project gl , interp_uconstr ist (pf_env gl) c
-  )
+  let interp ist tac = interp_tactic ist tac >>= fun () -> Ftactic.return () in
+  register_interp0 wit_ltac interp
+
+let () =
+  register_interp0 wit_uconstr (fun ist c -> Ftactic.nf_enter { enter = begin fun gl ->
+    Ftactic.return (interp_uconstr ist (Proofview.Goal.env gl) c)
+  end })
 
 (***************************************************************************)
 (* Other entry points *)
@@ -2358,24 +2106,13 @@ let interp_redexp env sigma r =
   interp_red_expr ist env sigma (intern_red_expr gist r)
 
 (***************************************************************************)
-(* Embed tactics in raw or glob tactic expr *)
-
-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 -> anomaly ~label:"tacticIn"
-      (str "Incorrect tactic expression. Received exception is:" ++
-       Errors.print e))
-
-(***************************************************************************)
 (* Backwarding recursive needs of tactic glob/interp/eval functions *)
 
 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
+    if Genarg.has_type arg (glbwit wit_tactic) then
+      let tac = Genarg.out_gen (glbwit wit_tactic) arg in
       let tac = interp_tactic ist tac in
       Pfedit.refine_by_tactic env sigma ty tac
     else
@@ -2383,20 +2120,14 @@ let _ =
   in
   Hook.set Pretyping.genarg_interp_hook eval
 
-let _ = Hook.set Auto.extern_interp
-  (fun l ->
-    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 tac _ ist = Proofview.Goal.enter { enter = begin fun gl ->
     let env = Proofview.Goal.env gl in
-    let sigma = Proofview.Goal.sigma gl in
+    let sigma = project gl in
     let map = function
     | None -> None
     | Some id ->
@@ -2407,5 +2138,30 @@ let lift_constr_tac_to_ml_tac vars tac =
     in
     let args = List.map_filter map vars in
     tac args ist
-  end in
+  end } in
   tac
+
+let vernac_debug b =
+  set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff)
+
+let _ =
+  let open Goptions in
+  declare_bool_option
+    { optsync  = false;
+      optdepr  = false;
+      optname  = "Ltac debug";
+      optkey   = ["Ltac";"Debug"];
+      optread  = (fun () -> get_debug () != Tactic_debug.DebugOff);
+      optwrite = vernac_debug }
+
+let _ =
+  let open Goptions in
+  declare_bool_option
+    { optsync  = false;
+      optdepr  = false;
+      optname  = "Ltac debug";
+      optkey   = ["Debug";"Ltac"];
+      optread  = (fun () -> get_debug () != Tactic_debug.DebugOff);
+      optwrite = vernac_debug }
+
+let () = Hook.set Vernacentries.interp_redexp_hook interp_redexp
diff --git a/tactics/tacinterp.mli b/ltac/tacinterp.mli
index ac7e2149..6f64981e 100644
--- a/tactics/tacinterp.mli
+++ b/ltac/tacinterp.mli
@@ -14,15 +14,18 @@ open Genarg
 open Redexpr
 open Misctypes
 
+val ltac_trace_info : ltac_trace Exninfo.t
+
 module Value :
 sig
-  type t = tlevel generic_argument
+  type t = Geninterp.Val.t
   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
+  val cast : 'a typed_abstract_argument_type -> Geninterp.Val.t -> 'a
 end
 
 (** Values for interpretation *)
@@ -45,14 +48,6 @@ val extract_ltac_constr_values : interp_sign -> Environ.env ->
 (** 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
-val tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr)
-
-val tacticIn : (interp_sign -> raw_tactic_expr) -> raw_tactic_expr
-val globTacticIn : (interp_sign -> glob_tactic_expr) -> raw_tactic_expr
-val valueIn : value -> raw_tactic_arg
-
 (** Sets the debugger mode *)
 val set_debug : debug_info -> unit
 
@@ -61,10 +56,7 @@ val get_debug : unit -> debug_info
 
 (** Adds an interpretation function for extra generic arguments *)
 
-(* 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
+val interp_genarg : interp_sign -> glob_generic_argument -> Value.t Ftactic.t
 
 (** Interprets any expression *)
 val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tactic) -> unit Proofview.tactic
@@ -80,6 +72,9 @@ val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map
 val interp_hyp : interp_sign -> Environ.env -> Evd.evar_map ->
   Id.t Loc.located -> Id.t
 
+val interp_constr_gen : Pretyping.typing_constraint -> interp_sign ->
+  Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Evd.evar_map * constr
+
 val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map ->
  glob_constr_and_expr bindings -> Evd.evar_map * constr bindings
 
@@ -93,6 +88,8 @@ val eval_tactic : glob_tactic_expr -> unit Proofview.tactic
 val eval_tactic_ist : interp_sign -> glob_tactic_expr -> unit Proofview.tactic
 (** Same as [eval_tactic], but with the provided [interp_sign]. *)
 
+val tactic_of_value : interp_sign -> Value.t -> unit Proofview.tactic
+
 (** Globalization + interpretation *)
 
 val interp_tac_gen : value Id.Map.t -> Id.t list ->
diff --git a/tactics/tacsubst.ml b/ltac/tacsubst.ml
index cef630da..cce4382c 100644
--- a/tactics/tacsubst.ml
+++ b/ltac/tacsubst.ml
@@ -16,7 +16,6 @@ open Globnames
 open Term
 open Genredexpr
 open Patternops
-open Pretyping
 
 (** Substitution of tactics at module closing time *)
 
@@ -54,11 +53,17 @@ 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)
+      IntroOrAndPattern (subst_intro_or_and_pattern subst l)
   | IntroInjection l -> IntroInjection (List.map (subst_intro_pattern subst) l)
   | IntroWildcard | IntroRewrite _ as x -> x
 
-let subst_induction_arg subst = function
+and subst_intro_or_and_pattern subst = function
+  | IntroAndPattern l ->
+      IntroAndPattern (List.map (subst_intro_pattern subst) l)
+  | IntroOrPattern ll ->
+      IntroOrPattern (List.map (List.map (subst_intro_pattern subst)) ll)
+
+let subst_destruction_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
@@ -88,7 +93,7 @@ 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 " ++
+    Feedback.msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++
           str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++
           pr_global ref') ;
    ref'
@@ -101,8 +106,8 @@ let subst_evaluable subst =
 
 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_glob_constr_or_pattern subst (bvars,c,p) =
+  (bvars,subst_glob_constr subst c,subst_pattern subst p)
 
 let subst_redexp subst =
   Miscops.map_red_expr_gen
@@ -131,49 +136,31 @@ let rec subst_match_goal_hyps subst = function
 
 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)
+  | TacIntroPattern (ev,l) -> TacIntroPattern (ev,List.map (subst_intro_pattern subst) l)
   | 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)
+      TacAssert (b,Option.map (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
+        subst_destruction_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)
@@ -181,9 +168,6 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
       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,
@@ -245,34 +229,26 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with
   | TacSolve l -> TacSolve (List.map (subst_tactic subst) l)
   | TacComplete tac -> TacComplete (subst_tactic subst tac)
   | TacArg (_,a) -> TacArg (dloc,subst_tacarg subst a)
+  | TacSelect (s, tac) -> TacSelect (s, subst_tactic subst tac)
 
   (* 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)
+      TacAlias (dloc,s,List.map (subst_tacarg subst) l)
+  | TacML (_loc,opn,l) -> TacML (dloc,opn,List.map (subst_tacarg 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 ">"))
+  | TacGeneric arg -> TacGeneric (subst_genarg subst arg)
 
 (* Reads the rules of a Match Context or a Match *)
 and subst_match_rule subst = function
@@ -285,66 +261,47 @@ and subst_match_rule subst = function
       ::(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))
+and subst_genarg subst (GenArg (Glbwit wit, x)) =
+  match wit with
+  | ListArg wit ->
+    let map x =
+      let ans = subst_genarg subst (in_gen (glbwit wit) x) in
+      out_gen (glbwit wit) ans
     in
-    list_unpack { list_unpacker } x
-  | OptArgType _ ->
-    let opt_unpacker wit o = match glb o with
+    in_gen (glbwit (wit_list wit)) (List.map map x)
+  | OptArg wit ->
+    let ans = match x 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
+    ans
+  | PairArg (wit1, wit2) ->
+    let p, q = x 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)
+  | ExtraArg s ->
+      Genintern.generic_substitute subst (in_gen (glbwit wit) x)
 
 (** Registering *)
 
 let () =
+  Genintern.register_subst0 wit_int_or_var (fun _ v -> v);
   Genintern.register_subst0 wit_ref subst_global_reference;
+  Genintern.register_subst0 wit_ident (fun _ v -> v);
+  Genintern.register_subst0 wit_var (fun _ v -> v);
   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_ltac subst_tactic;
+  Genintern.register_subst0 wit_constr subst_glob_constr;
   Genintern.register_subst0 wit_clause_dft_concl (fun _ v -> v);
-  Genintern.register_subst0 wit_uconstr (fun subst c -> subst_glob_constr subst c)
+  Genintern.register_subst0 wit_uconstr (fun subst c -> subst_glob_constr subst c);
+  Genintern.register_subst0 wit_open_constr (fun subst c -> subst_glob_constr subst c);
+  Genintern.register_subst0 wit_red_expr subst_redexp;
+  Genintern.register_subst0 wit_quant_hyp subst_declared_or_quantified_hypothesis;
+  Genintern.register_subst0 wit_bindings subst_bindings;
+  Genintern.register_subst0 wit_constr_with_bindings subst_glob_with_bindings;
+  Genintern.register_subst0 wit_destruction_arg subst_destruction_arg;
+  ()
diff --git a/tactics/tacsubst.mli b/ltac/tacsubst.mli
index c1bf2725..c1bf2725 100644
--- a/tactics/tacsubst.mli
+++ b/ltac/tacsubst.mli
diff --git a/proofs/tactic_debug.ml b/ltac/tactic_debug.ml
index a4a447e8..5cbddc7f 100644
--- a/proofs/tactic_debug.ml
+++ b/ltac/tactic_debug.ml
@@ -12,11 +12,18 @@ open Pp
 open Tacexpr
 open Termops
 open Nameops
+open Proofview.Notations
 
-let (prtac, tactic_printer) = Hook.make ()
-let (prmatchpatt, match_pattern_printer) = Hook.make ()
-let (prmatchrl, match_rule_printer) = Hook.make ()
 
+let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make ()
+
+let prtac x =
+  Pptactic.pr_glob_tactic (Global.env()) x
+let prmatchpatt env sigma hyp =
+  Pptactic.pr_match_pattern (Printer.pr_constr_pattern_env env sigma) hyp
+let prmatchrl rl =
+  Pptactic.pr_match_rule false (Pptactic.pr_glob_tactic (Global.env()))
+    (fun (_,p) -> Printer.pr_constr_pattern p) rl
 
 (* 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
@@ -28,9 +35,12 @@ type debug_info =
   | DebugOff
 
 (* An exception handler *)
-let explain_logic_error = ref (fun e -> mt())
+let explain_logic_error e =
+  CErrors.print (fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null)))
 
-let explain_logic_error_no_anomaly = ref (fun e -> mt())
+let explain_logic_error_no_anomaly e =
+  CErrors.print_no_report
+    (fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null)))
 
 let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl())
 let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl())
@@ -47,10 +57,10 @@ let db_pr_goal gl =
                    str" "  ++ pc) ++ fnl ()
 
 let db_pr_goal =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let pg = db_pr_goal gl in
   Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg))
-  end
+  end }
 
 
 (* Prints the commands *)
@@ -66,7 +76,7 @@ let help () =
 let goal_com tac =
   Proofview.tclTHEN
     db_pr_goal
-    (Proofview.tclLIFT (msg_tac_debug (str "Going to execute:" ++ fnl () ++ Hook.get prtac tac)))
+    (Proofview.tclLIFT (msg_tac_debug (str "Going to execute:" ++ fnl () ++ prtac tac)))
 
 (* [run (new_ref _)] gives us a ref shared among [NonLogical.t]
    expressions. It avoids parametrizing everything over a
@@ -196,7 +206,7 @@ let debug_prompt lev tac f =
         (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)
+              msg_tac_debug (str "Level " ++ int lev ++ str ": " ++ explain_logic_error reraise)
             else return ()
         end)
         (Proofview.tclZERO ~info reraise)
@@ -227,7 +237,7 @@ let db_pattern_rule debug num r =
   if db then
   begin
     msg_tac_debug (str "Pattern rule " ++ int num ++ str ":" ++ fnl () ++
-      str "|" ++ spc () ++ Hook.get prmatchrl r)
+      str "|" ++ spc () ++ prmatchrl r)
   end
   else return ()
 
@@ -269,7 +279,7 @@ let db_hyp_pattern_failure debug env sigma (na,hyp) =
   if db then
     msg_tac_debug (str "The pattern hypothesis" ++ hyp_bound na ++
                 str " cannot match: " ++
-           Hook.get prmatchpatt env sigma hyp)
+           prmatchpatt env sigma hyp)
   else return ()
 
 (* Prints a matching failure message for a rule *)
@@ -298,7 +308,7 @@ let db_logic_failure debug err =
   is_debug debug >>= fun db ->
   if db then
   begin
-    msg_tac_debug (Pervasives.(!) explain_logic_error err) >>
+    msg_tac_debug (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
@@ -316,3 +326,97 @@ let db_breakpoint debug s =
       breakpoint:=None
   | _ ->
       return ()
+
+(** Extrating traces *)
+
+let is_defined_ltac trace =
+  let rec aux = function
+  | (_, Tacexpr.LtacNameCall f) :: _ -> not (Tacenv.is_ltac_for_ml_tactic f)
+  | (_, Tacexpr.LtacNotationCall f) :: _ -> true
+  | (_, Tacexpr.LtacAtomCall _) :: _ -> 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
+    | Tacexpr.LtacNotationCall kn -> quote (Pptactic.pr_alias_key kn)
+  | Tacexpr.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst)
+  | Tacexpr.LtacMLCall t ->
+      quote (Pptactic.pr_glob_tactic (Global.env()) t)
+  | Tacexpr.LtacVarCall (id,t) ->
+      quote (Nameops.pr_id id) ++ strbrk " (bound to " ++
+        Pptactic.pr_glob_tactic (Global.env()) t ++ str ")"
+  | Tacexpr.LtacAtomCall te ->
+      quote (Pptactic.pr_glob_tactic (Global.env())
+              (Tacexpr.TacAtom (Loc.ghost,te)))
+  | Tacexpr.LtacConstrInterp (c, { Pretyping.ltac_constrs = vars }) ->
+      quote (Printer.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
+  match calls with
+  | [] -> mt ()
+  | [a] -> hov 0 (str "Ltac call to " ++ pr_call a ++ str " failed.")
+  | _ ->
+    let kind_of_last_call = match List.last calls with
+    | Tacexpr.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
+  | (_,Tacexpr.LtacNameCall f as tac) :: _
+       when Tacenv.is_ltac_for_ml_tactic f -> [tac]
+  | (_,Tacexpr.LtacNotationCall _ as tac) :: (_,Tacexpr.LtacMLCall _) :: _ ->
+     (* Case of an ML defined tactic with entry of the form <<"foo" args>> *)
+     (* see tacextend.mlp *)
+     [tac]
+  | (_,Tacexpr.LtacMLCall _ as tac) :: _ -> [tac]
+  | t :: tail -> t :: aux tail
+  | [] -> [] in
+  List.rev (aux (List.rev trace))
+
+let finer_loc loc1 loc2 = Loc.merge loc1 loc2 = loc2
+
+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, if finer_loc eloc loc then eloc else loc
+  else
+    (* We entered a primitive tactic, we don't display trace but
+       report on the finest location *)
+    let best_loc =
+      (* trace is with innermost call coming first *)
+      let rec aux best_loc = function
+        | (loc,_)::tail ->
+           if Loc.is_ghost best_loc ||
+              not (Loc.is_ghost loc) && finer_loc loc best_loc
+           then
+             aux loc tail
+           else
+             aux best_loc tail
+        | [] -> best_loc in
+        aux eloc trace in
+    None, best_loc
+
+let get_ltac_trace (_, info) =
+  let ltac_trace = Exninfo.get info ltac_trace_info in
+  let loc = Option.default Loc.ghost (Loc.get_loc info) in
+  match ltac_trace with
+  | None -> None
+  | Some trace -> Some (extract_ltac_trace trace loc)
+
+let () = ExplainErr.register_additional_error_info get_ltac_trace
diff --git a/proofs/tactic_debug.mli b/ltac/tactic_debug.mli
index 215c5b29..520fb41e 100644
--- a/proofs/tactic_debug.mli
+++ b/ltac/tactic_debug.mli
@@ -13,16 +13,14 @@ open Tacexpr
 open Term
 open Evd
 
+(** TODO: Move those definitions somewhere sensible *)
+
+val ltac_trace_info : ltac_trace Exninfo.t
+
 (** 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 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 =
   | DebugOn of int
@@ -63,13 +61,13 @@ val db_matching_failure : debug_info -> unit Proofview.NonLogical.t
 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
+val explain_logic_error: exn -> Pp.std_ppcmds
 
 (** For use in the Ltac debugger: some exception that are usually
    consider anomalies are acceptable because they are caught later in
    the process that is being debugged.  One should not require
    from users that they report these anomalies. *)
-val explain_logic_error_no_anomaly : (exn -> Pp.std_ppcmds) ref
+val explain_logic_error_no_anomaly : exn -> Pp.std_ppcmds
 
 (** Prints a logic failure message for a rule *)
 val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t
@@ -77,3 +75,6 @@ val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t
 (** Prints a logic failure message for a rule *)
 val db_breakpoint : debug_info ->
   Id.t Loc.located message_token list -> unit Proofview.NonLogical.t
+
+val extract_ltac_trace :
+  Tacexpr.ltac_trace -> Loc.t -> Pp.std_ppcmds option * Loc.t
diff --git a/tactics/tactic_option.ml b/ltac/tactic_option.ml
index a5ba3b83..a5ba3b83 100644
--- a/tactics/tactic_option.ml
+++ b/ltac/tactic_option.ml
diff --git a/tactics/tactic_option.mli b/ltac/tactic_option.mli
index ed759a76..ed759a76 100644
--- a/tactics/tactic_option.mli
+++ b/ltac/tactic_option.mli
diff --git a/ltac/tauto.ml b/ltac/tauto.ml
new file mode 100644
index 00000000..756958c2
--- /dev/null
+++ b/ltac/tauto.ml
@@ -0,0 +1,279 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Term
+open Hipattern
+open Names
+open Pp
+open Geninterp
+open Misctypes
+open Tacexpr
+open Tacinterp
+open Util
+open Tacticals.New
+
+let tauto_plugin = "tauto"
+let () = Mltop.add_known_module tauto_plugin
+
+let assoc_var s ist =
+  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 *)
+  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 *)
+  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 *)
+  strict_in_hyp_and_ccl : bool;
+
+(* Whether unit type includes equality types *)
+  strict_unit : bool;
+}
+
+let tag_tauto_flags : tauto_flags Val.typ = Val.create "tauto_flags"
+
+let assoc_flags ist : tauto_flags =
+  let Val.Dyn (tag, v) = Id.Map.find (Names.Id.of_string "tauto_flags") ist.lfun in
+  match Val.eq tag tag_tauto_flags with
+  | None -> assert false
+  | Some Refl -> v
+
+(* Whether inner not are unfolded *)
+let negation_unfolding = ref true
+
+(* Whether inner iff are unfolded *)
+let iff_unfolding = ref false
+
+let unfold_iff () = !iff_unfolding || Flags.version_less_or_equal Flags.V8_2
+
+open Goptions
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      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 }
+
+(** Base tactics *)
+
+let loc = Loc.ghost
+let idtac = Proofview.tclUNIT ()
+let fail = Proofview.tclINDEPENDENT (tclFAIL 0 (Pp.mt ()))
+
+let intro = Tactics.intro
+
+let assert_ ?by c =
+  let tac = match by with
+  | None -> None
+  | Some tac -> Some (Some tac)
+  in
+  Proofview.tclINDEPENDENT (Tactics.forward true tac None c)
+
+let apply c = Tactics.apply c
+
+let clear id = Tactics.clear [id]
+
+let assumption = Tactics.assumption
+
+let split = Tactics.split_with_bindings false [Misctypes.NoBindings]
+
+(** Test *)
+
+let is_empty _ ist =
+  if is_empty_type (assoc_var "X1" ist) then idtac else fail
+
+(* 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 flags = assoc_flags ist in
+  let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in
+  if test (assoc_var "X1" ist) then idtac else fail
+
+let bugged_is_binary t =
+  isApp t &&
+  let (hdapp,args) = decompose_app t in
+    match (kind_of_term hdapp) with
+    | Ind (ind,u)  ->
+        let (mib,mip) = Global.lookup_inductive ind in
+         Int.equal mib.Declarations.mind_nparams 2
+    | _ -> false
+
+(** Dealing with conjunction *)
+
+let is_conj _ ist =
+  let flags = assoc_flags ist in
+  let ind = assoc_var "X1" ist in
+    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 idtac
+    else fail
+
+let flatten_contravariant_conj _ ist =
+  let flags = assoc_flags ist in
+  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:flags.strict_in_contravariant_hyp
+          ~onlybinary:flags.binary_mode typ
+  with
+  | Some (_,args) ->
+    let newtyp = List.fold_right mkArrow args c in
+    let intros = tclMAP (fun _ -> intro) args in
+    let by = tclTHENLIST [intros; apply hyp; split; assumption] in
+    tclTHENLIST [assert_ ~by newtyp; clear (destVar hyp)]
+  | _ -> fail
+
+(** Dealing with disjunction *)
+
+let is_disj _ ist =
+  let flags = assoc_flags ist in
+  let t = assoc_var "X1" ist in
+  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 idtac
+  else fail
+
+let flatten_contravariant_disj _ ist =
+  let flags = assoc_flags ist in
+  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:flags.strict_in_contravariant_hyp
+          ~onlybinary:flags.binary_mode
+          typ with
+  | Some (_,args) ->
+      let map i arg =
+        let typ = mkArrow arg c in
+        let ci = Tactics.constructor_tac false None (succ i) Misctypes.NoBindings in
+        let by = tclTHENLIST [intro; apply hyp; ci; assumption] in
+        assert_ ~by typ
+      in
+      let tacs = List.mapi map args in
+      let tac0 = clear (destVar hyp) in
+      tclTHEN (tclTHENLIST tacs) tac0
+  | _ -> fail
+
+let make_unfold name =
+  let dir = DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]) in
+  let const = Constant.make2 (MPfile dir) (Label.make name) in
+  (Locus.AllOccurrences, ArgArg (EvalConstRef const, None))
+
+let u_iff = make_unfold "iff"
+let u_not = make_unfold "not"
+
+let reduction_not_iff _ ist =
+  let make_reduce c = TacAtom (loc, TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in
+  let tac = match !negation_unfolding, unfold_iff () with
+    | true, true -> make_reduce [u_not; u_iff]
+    | true, false -> make_reduce [u_not]
+    | false, true -> make_reduce [u_iff]
+    | false, false -> TacId []
+  in
+  eval_tactic_ist ist tac
+
+let coq_nnpp_path =
+  let dir = List.map Id.of_string ["Classical_Prop";"Logic";"Coq"] in
+  Libnames.make_path (DirPath.make dir) (Id.of_string "NNPP")
+
+let apply_nnpp _ ist =
+  Proofview.tclBIND
+    (Proofview.tclUNIT ())
+    begin fun () -> try
+      let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in
+      apply nnpp
+    with Not_found -> tclFAIL 0 (Pp.mt ())
+    end
+
+(* 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 with_flags flags _ ist =
+  let f = (loc, Id.of_string "f") in
+  let x = (loc, Id.of_string "x") in
+  let arg = Val.Dyn (tag_tauto_flags, flags) in
+  let ist = { ist with lfun = Id.Map.add (snd x) arg ist.lfun } in
+  eval_tactic_ist ist (TacArg (loc, TacCall (loc, ArgVar f, [Reference (ArgVar x)])))
+
+let register_tauto_tactic tac name0 args =
+  let ids = List.map (fun id -> Id.of_string id) args in
+  let ids = List.map (fun id -> Some id) ids in
+  let name = { mltac_plugin = tauto_plugin; mltac_tactic = name0; } in
+  let entry = { mltac_name = name; mltac_index = 0 } in
+  let () = Tacenv.register_ml_tactic name [| tac |] in
+  let tac = TacFun (ids, TacML (loc, entry, [])) in
+  let obj () = Tacenv.register_ltac true true (Id.of_string name0) tac in
+  Mltop.declare_cache_obj obj tauto_plugin
+
+let () = register_tauto_tactic is_empty "is_empty" ["tauto_flags"; "X1"]
+let () = register_tauto_tactic is_unit_or_eq "is_unit_or_eq" ["tauto_flags"; "X1"]
+let () = register_tauto_tactic is_disj "is_disj" ["tauto_flags"; "X1"]
+let () = register_tauto_tactic is_conj "is_conj" ["tauto_flags"; "X1"]
+let () = register_tauto_tactic flatten_contravariant_disj "flatten_contravariant_disj" ["tauto_flags"; "X1"; "X2"; "id"]
+let () = register_tauto_tactic flatten_contravariant_conj "flatten_contravariant_conj" ["tauto_flags"; "X1"; "X2"; "id"]
+let () = register_tauto_tactic apply_nnpp "apply_nnpp" []
+let () = register_tauto_tactic reduction_not_iff "reduction_not_iff" []
+let () = register_tauto_tactic (with_flags tauto_uniform_unit_flags) "with_uniform_flags" ["f"]
+let () = register_tauto_tactic (with_flags tauto_power_flags) "with_power_flags" ["f"]
diff --git a/dev/tools/Makefile.common b/ltac/tauto.mli
index e69de29b..e69de29b 100644
--- a/dev/tools/Makefile.common
+++ b/ltac/tauto.mli
diff --git a/myocamlbuild.ml b/myocamlbuild.ml
deleted file mode 100644
index 097a1042..00000000
--- a/myocamlbuild.ml
+++ /dev/null
@@ -1,483 +0,0 @@
-(** * Plugin for building Coq via Ocamlbuild *)
-
-open Ocamlbuild_plugin
-open Ocamlbuild_pack
-open Printf
-open Scanf
-
-(** WARNING !! this is preliminary stuff. It should allows you to
-    build coq and its libraries if everything goes right.
-    Support for all the build rules and configuration options
-    is progressively added. Tested only on linux + ocaml 3.11 +
-    local + natdynlink for now.
-
-    Usage:
-     ./configure -local -opt
-     ./build   (which launches ocamlbuild coq.otarget)
-
-    Then you can (hopefully) launch bin/coqtop, bin/coqide and so on.
-    Apart from the links in bin, every created files are in _build.
-    A "./build clean" should give you back a clean source tree
-
-*)
-
-(** F.A.Q about ocamlbuild:
-
-* P / Px ?
-
- Same, except that the second can be use to signal the main target
- of a rule, in order to get a nicer log (otherwise the full command
- is used as target name)
-
-*)
-
-
-
-(** Generic file reader, which produces a list of strings, one per line *)
-
-let read_file f =
-  let ic = open_in f and l = ref [] in
-  (try while true do l := (input_line ic)::!l done with End_of_file -> ());
-  close_in ic; List.rev !l
-
-
-(** Configuration *)
-
-(** First, we access coq_config.ml indirectly : we symlink it to
-    myocamlbuild_config.ml, which is linked with this myocamlbuild.ml *)
-
-module Coq_config = struct include Myocamlbuild_config end
-
-let _ = begin
-  Options.ocamlc := A Coq_config.ocamlc;
-  Options.ocamlopt := A Coq_config.ocamlopt;
-  Options.ocamlmklib := A Coq_config.ocamlmklib;
-  Options.ocamldep := A Coq_config.ocamldep;
-  Options.ocamldoc := A Coq_config.ocamldoc;
-  Options.ocamlyacc := A Coq_config.ocamlyacc;
-  Options.ocamllex := A Coq_config.ocamllex;
-end
-
-let w32 = Coq_config.arch_is_win32
-
-let w32pref = "i586-mingw32msvc"
-let w32ocamlc = w32pref^"-ocamlc"
-let w32ocamlopt = w32pref^"-ocamlopt"
-let w32ocamlmklib = w32pref^"-ocamlmklib"
-let w32res = w32pref^"-windres"
-let w32lib = "/usr/"^w32pref^"/lib/"
-let w32bin = "/usr/"^w32pref^"/bin/"
-let w32ico = "ide/coq_icon.o"
-
-let _ = if w32 then begin
-  Options.ocamlopt := A w32ocamlopt;
-  Options.ocamlmklib := A w32ocamlmklib;
-end
-
-let use_camlp5 = (Coq_config.camlp4 = "camlp5")
-
-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 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 dep_dynlink = if hasdynlink then N else Sh"-natdynlink no"
-let lablgtkincl = Sh Coq_config.coqideincl
-let local = Coq_config.local
-let cflags = S[A"-ccopt";A Coq_config.cflags]
-
-(** Do we want to inspect .ml generated from .ml4 ? *)
-let readable_genml = false
-let readable_flag = if readable_genml then A"pr_o.cmo" else N
-
-let _build = Options.build_dir
-
-
-(** Abbreviations about files *)
-
-let core_libs =
-  ["lib/clib"; "lib/lib"; "kernel/kernel"; "library/library";
-   "pretyping/pretyping"; "interp/interp";  "proofs/proofs";
-   "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 = "tools/tolink.ml"
-
-let c_headers_base =
-  ["coq_fix_code.h";"coq_instruct.h"; "coq_memory.h"; "int64_emul.h";
-   "coq_gc.h"; "coq_interp.h"; "coq_values.h"; "int64_native.h";
-   "coq_jumptbl.h"]
-let c_headers = List.map ((^) "kernel/byterun/") c_headers_base
-
-let coqinstrs = "kernel/byterun/coq_instruct.h"
-let coqjumps = "kernel/byterun/coq_jumptbl.h"
-let copcodes = "kernel/copcodes.ml"
-
-let libcoqrun = "kernel/byterun/libcoqrun.a"
-
-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"
-
-let adapt_name (pref,oldsuf,newsuf) f =
- pref ^ (Filename.chop_suffix f oldsuf) ^ newsuf
-
-let get_names (oldsuf,newsuf) s =
-  let pref = Filename.dirname s ^ "/" in
-  List.map (adapt_name (pref,oldsuf,newsuf)) (string_list_of_file s)
-
-let get_vo_itargets f =
-  let vo_itargets = get_names (".otarget",".itarget") f in
-  List.flatten (List.map (get_names (".vo",".v")) vo_itargets)
-
-let theoriesv = get_vo_itargets "theories/theories.itarget"
-
-let pluginsv = get_vo_itargets "plugins/pluginsvo.itarget"
-
-let pluginsmllib = get_names (".cma",".mllib") "plugins/pluginsbyte.itarget"
-
-(** for correct execution of coqdep_boot, source files should have
-    been imported in _build (and NMake_gen.v should have been created). *)
-
-let coqdepdeps = theoriesv @ pluginsv @ pluginsmllib
-
-let coqtop = "toplevel/coqtop"
-let coqide = "ide/coqide"
-let coqdepboot = "tools/coqdep_boot"
-let coqmktop = "tools/coqmktop"
-
-(** The list of binaries to build:
-    (name of link in bin/, name in _build, install both or only best) *)
-
-type links = Both | Best | BestInPlace | Ide
-
-let all_binaries =
- (if w32 then [ "mkwinapp", "tools/mkwinapp", Best ] else []) @
- [ "coqtop", coqtop, Both;
-   "coqide", "ide/coqide_main", Ide;
-   "coqmktop", coqmktop, Both;
-   "coqc", "tools/coqc", Both;
-   "coqchk", "checker/main", Both;
-   "coqdep_boot", coqdepboot, Best;
-   "coqdep", "tools/coqdep", Best;
-   "coqdoc", "tools/coqdoc/main", Best;
-   "coqwc", "tools/coqwc", Best;
-   "coq_makefile", "tools/coq_makefile", Best;
-   "coq-tex", "tools/coq_tex", Best;
-   "gallina", "tools/gallina", Best;
-   "csdpcert", "plugins/micromega/csdpcert", BestInPlace;
-   "fake_ide", "tools/fake_ide", Best;
- ]
-
-
-let best_oext = if opt then ".native" else ".byte"
-let best_ext = if opt then ".opt" else ".byte"
-let best_iext = if ide = "opt" then ".opt" else ".byte"
-
-let coqtopbest = coqtop^best_oext
-(* For inner needs, we rather use the bytecode versions of coqdep
-   and coqmktop: slightly slower but compile quickly, and ok with
-   w32 cross-compilation *)
-let coqdep_boot = coqdepboot^".byte"
-let coqmktop_boot = coqmktop^".byte"
-
-let binariesopt_deps =
-  let addext b = b ^ ".native" in
-  let rec deps = function
-    | [] -> []
-    | (_,b,Ide)::l -> if ide="opt" then addext b :: deps l else deps l
-    | (_,b,_)::l -> if opt then addext b :: deps l else deps l
-  in deps all_binaries
-
-let binariesbyte_deps =
-  let addext b = b ^ ".byte" in
-  let rec deps = function
-    | [] -> []
-    | (_,b,Ide)::l -> if ide<>"no" then addext b :: deps l else deps l
-    | (_,b,Both)::l -> addext b :: deps l
-    | (_,b,_)::l -> if not opt then addext b :: deps l else deps l
-  in deps all_binaries
-
-let ln_sf toward f =
-  Command.execute ~quiet:true (Cmd (S [A"ln";A"-sf";P toward;P f]))
-
-let rec make_bin_links = function
-  | [] -> ()
-  | (b,ob,kind)::l ->
-      make_bin_links l;
-      let obd = "../"^ !_build^"/"^ob and bd = "bin/"^b in
-      match kind with
-	| Ide when ide <> "no" ->
-	    ln_sf (obd^".byte") (bd^".byte");
-	    if ide = "opt" then ln_sf (obd^".native") (bd^".opt");
-	    ln_sf (b^best_iext) bd
-	| Ide (* when ide = "no" *) -> ()
-	| Both ->
-	    ln_sf (obd^".byte") (bd^".byte");
-	    if opt then ln_sf (obd^".native") (bd^".opt");
-	    ln_sf (b^best_ext) bd
-	| Best -> ln_sf (obd^best_oext) bd
-	| BestInPlace -> ln_sf (b^best_oext) (!_build^"/"^ob)
-
-let incl f = Ocaml_utils.ocaml_include_flags f
-
-let cmd cl = (fun _ _ -> (Cmd (S cl)))
-
-let initial_actions () = begin
-  (** We "pre-create" a few subdirs in _build *)
-  Shell.mkdir_p (!_build^"/dev");
-  Shell.mkdir_p (!_build^"/bin");
-  Shell.mkdir_p (!_build^"/plugins/micromega");
-  make_bin_links all_binaries;
-end
-
-let extra_rules () = begin
-
-(** Virtual target for building all binaries *)
-
-  rule "binariesopt" ~stamp:"binariesopt" ~deps:binariesopt_deps (fun _ _ -> Nop);
-  rule "binariesbyte" ~stamp:"binariesbyte" ~deps:binariesbyte_deps (fun _ _ -> Nop);
-  rule "binaries" ~stamp:"binaries" ~deps:["binariesbyte";"binariesopt"] (fun _ _ -> Nop);
-
-(** We create a special coq_config which mentions _build *)
-
-  rule "coq_config.ml" ~prod:"coq_config.ml" ~dep:"config/coq_config.ml"
-    (fun _ _ ->
-       if w32 then cp "config/coq_config.ml" "coq_config.ml" else
-       let lines = read_file "config/coq_config.ml" in
-       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 -vmbyteflags foo isn't supported *)
-       let line1 =
-	 "let vmbyteflags = [\"-dllib\";\"-lcoqrun\"]\n"
-       in
-       Echo (lines @ (if local then [line0;line1] else []),
-	     "coq_config.ml"));
-
-(** Camlp4 extensions *)
-
-  rule ".ml4.ml" ~dep:"%.ml4" ~prod:"%.ml"
-    (fun env _ ->
-       let ml4 = env "%.ml4" and ml = env "%.ml" in
-       Cmd (S[camlp4o;T(tags_of_pathname ml4 ++ "p4mod");readable_flag;
-	      T(tags_of_pathname ml4 ++ "p4option"); camlp4compat;
-	      A"-o"; Px ml; A"-impl"; P ml4]));
-
-  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");
-
-  if w32 then begin
-    flag ["p4mod"] (A "-DWIN32");
-    dep ["ocaml"; "link"; "ide"] ["ide/ide_win32_stubs.o"];
-  end;
-
-  if not use_camlp5 then begin
-  let mlp_cmo s =
-    let src=s^".mlp" and dst=s^".cmo" in
-    rule (src^".cmo") ~dep:src ~prod:dst ~insert:`top
-      (fun env _ ->
-	 Cmd (S [!Options.ocamlc; A"-c"; A"-pp";
-		 Quote (S [camlp4o;A"-impl"]); camlp4incl; A"-impl"; P src]))
-  in
-  mlp_cmo "tools/compat5";
-  mlp_cmo "tools/compat5b";
-  end;
-
-(** All caml files are compiled with +camlp4/5
-    and ide files need +lablgtk2 *)
-
-  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"lablgtksourceview2.cma"]);
-  flag ["ocaml"; "ide"; "link"; "native"]
-    (S [A"lablgtk.cmxa"; A"lablgtksourceview2.cmxa"]);
-
-(** C code for the VM *)
-
-  dep ["compile"; "c"] c_headers;
-  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.vmbyteflags);
-
-  (* we need to use a different ocamlc. For now we copy the rule *)
-  if w32 then
-  rule ".c.o"  ~deps:("%.c"::c_headers) ~prod:"%.o" ~insert:`top
-    (fun env _ ->
-       let c = env "%.c" in
-       let o = env "%.o" in
-       Seq [Cmd (S [P w32ocamlc;cflags;A"-c";Px c]);
-	    mv  (Filename.basename o) o]);
-
-(** VM: Generation of coq_jumbtbl.h and copcodes.ml from coq_instruct.h *)
-
-  rule "coqinstrs" ~dep:coqinstrs ~prods:[coqjumps;copcodes]
-    (fun _ _ ->
-       let jmps = ref [] and ops = ref [] and i = ref 0 in
-       let add_instr instr comma =
-	 if instr = "" then failwith "Empty" else begin
-	   jmps:=sprintf "&&coq_lbl_%s%s \n" instr comma :: !jmps;
-	   ops:=sprintf "let op%s = %d\n" instr !i :: !ops;
-	   incr i
-	 end
-       in
-       (** we recognize comma-separated uppercase instruction names *)
-       let parse_line s =
-	 let b = Scanning.from_string s in
-	 try while true do bscanf b " %[A-Z0-9_]%[,]" add_instr done
-	 with _ -> ()
-       in
-       List.iter parse_line (read_file coqinstrs);
-       Seq [Echo (List.rev !jmps, coqjumps);
-	    Echo (List.rev !ops, copcodes)]);
-
-(** Generation of tolink.ml *)
-
-  rule tolink ~deps:core_mllib ~prod:tolink
-    (fun _ _ ->
-       let cat s = String.concat " " (string_list_of_file s) in
-       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 = \""^core_cmas^"\"\n";
-	      "let core_objs = \""^core_mods^"\"\n"],
-	     tolink));
-
-(** For windows, building coff object file from a .rc (for the icon) *)
-
-  if w32 then rule ".rc.o" ~deps:["%.rc";"ide/coq.ico"] ~prod:"%.o"
-    (fun env _ ->
-       let rc = env "%.rc" and o = env "%.o" in
-       Cmd (S [P w32res;A "--input-format";A "rc";A "--input";P rc;
-	       A "--output-format";A "coff";A "--output"; Px o]));
-
-(** 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"]
-    (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 =  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;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;A"-thread";camlp4incl;A"-o";Px fb]);
-  in
-
-(** Coq files dependencies *)
-
-  rule "coqdepready" ~stamp:"coqdepready" ~deps:coqdepdeps (fun _ _ -> Nop);
-
-  rule ".v.d" ~prod:"%.v.depends" ~deps:["%.v";coqdep_boot;"coqdepready"]
-    (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;P v;Sh">";Px vd]));
-
-(** Coq files compilation *)
-
-  let coq_build_dep f build =
-    (** NB: this relies on coqdep producing a single Makefile line
-	for one .v file, with some specific shape "f.vo ...: f.v deps.vo ..." *)
-    let src = f^".v" in
-    let depends = f^".v.depends" in
-    let rec get_deps keep = function
-      | [] -> []
-      | d::deps when d = src -> get_deps keep deps
-      | d::deps when keep -> [d] :: get_deps keep deps
-      | d::deps -> get_deps (String.contains d ':') deps
-    in
-    let d = get_deps false (string_list_of_file depends) in
-    List.iter Outcome.ignore_good (build d)
-
-  in
-
-  let coq_v_rule d init =
-    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 ->
-	 let f = env (d^"%") in
-	 coq_build_dep f build;
-	 Cmd (S [P coqtopbest;A"-boot";bootflag;A"-compile";Px f]))
-  in
-  coq_v_rule "theories/Init/" true;
-  coq_v_rule "" false;
-
-(** Generation of _plugin_mod.ml files *)
-
-  rule "_mod.ml" ~prod:"%_plugin_mod.ml" ~dep:"%_plugin.mllib"
-    (fun env _ ->
-       let line s = "let _ = Mltop.add_known_module \""^s^"\"\n" in
-       let mods =
-	 string_list_of_file (env "%_plugin.mllib") @
-	   [Filename.basename (env "%_plugin")]
-       in
-       Echo (List.map line mods, env "%_plugin_mod.ml"));
-
-(** Rule for native dynlinkable plugins *)
-
-  rule ".cmxa.cmxs" ~prod:"%.cmxs" ~dep:"%.cmxa"
-    (fun env _ ->
-       let cmxs = Px (env "%.cmxs") and cmxa = P (env "%.cmxa") in
-       if os5fix then
-	 Cmd (S [A"../dev/ocamlopt_shared_os5fix.sh"; !Options.ocamlopt; cmxs])
-       else
-	 Cmd (S [!Options.ocamlopt;A"-linkall";A"-shared";A"-o";cmxs;cmxa]));
-
-(** Generation of NMake.v from NMake_gen.ml *)
-
-  rule "NMake" ~prod:nmake ~dep:nmakegen
-    (cmd [ocaml;P nmakegen;Sh ">";Px nmake]);
-
-end
-
-(** Registration of our rules (after the standard ones) *)
-
-let _ = dispatch begin function
-  | After_rules -> initial_actions (); extra_rules ()
-  | _ -> ()
-end
-
-(** TODO / Remarques:
-
-    * Apres un premier build, le second prend du temps, meme cached:
-      1 min 25 pour les 2662 targets en cache. Etonnement, refaire
-      coqtop.byte ne prend que ~4s, au lieu des ~40s pour coqtop.opt.
-      A comprendre ...
-
-    * Parallelisation: vraiment pas top
-
-*)
diff --git a/parsing/lexer.ml4 b/parsing/cLexer.ml4
index 5d96873f..aec6a326 100644
--- a/parsing/lexer.ml4
+++ b/parsing/cLexer.ml4
@@ -8,8 +8,8 @@
 
 open Pp
 open Util
-open Compat
 open Tok
+open Compat
 
 (* Dictionaries: trees annotated with string options, each node being a map
    from chars to dictionaries (the subtrees). A trie, in other words. *)
@@ -69,6 +69,15 @@ let ttree_remove ttree str =
   in
   remove ttree 0
 
+let ttree_elements ttree =
+  let rec elts tt accu =
+    let accu = match tt.node with
+    | None -> accu
+    | Some s -> CString.Set.add s accu
+    in
+    CharMap.fold (fun _ tt accu -> elts tt accu) tt.branch accu
+  in
+  elts ttree CString.Set.empty
 
 (* Errors occurring while lexing (explained as "Lexer error: ...") *)
 
@@ -96,12 +105,12 @@ module Error = struct
              Printf.sprintf "Unsupported Unicode character (0x%x)" x)
 
   (* Require to fix the Camlp4 signature *)
-  let print ppf x = Pp.pp_with ppf (Pp.str (to_string x))
+  let print ppf x = Pp.pp_with ~pp_tag:Ppstyle.pp_tag ppf (Pp.str (to_string x))
 
 end
 open Error
 
-let err loc str = Loc.raise (Loc.make_loc loc) (Error.E str)
+let err loc str = Loc.raise (Compat.to_coqloc loc) (Error.E str)
 
 let bad_token str = raise (Error.E (Bad_token str))
 
@@ -112,64 +121,61 @@ type token_kind =
   | AsciiChar
   | EmptyStream
 
-let error_unsupported_unicode_character n unicode cs =
-  let bp = Stream.count cs in
-  err (bp,bp+n) (UnsupportedUnicode unicode)
-
-let error_utf8 cs =
+let error_utf8 loc cs =
   let bp = Stream.count cs in
   Stream.junk cs; (* consume the char to avoid read it and fail again *)
-  err (bp, bp+1) Illegal_character
+  let loc = set_loc_pos loc bp (bp+1) in
+  err loc Illegal_character
 
-let utf8_char_size cs = function
+let utf8_char_size loc cs = function
   (* Utf8 leading byte *)
   | '\x00'..'\x7F' -> 1
   | '\xC0'..'\xDF' -> 2
   | '\xE0'..'\xEF' -> 3
   | '\xF0'..'\xF7' -> 4
-  | _ (* '\x80'..\xBF'|'\xF8'..'\xFF' *) -> error_utf8 cs
+  | _ (* '\x80'..\xBF'|'\xF8'..'\xFF' *) -> error_utf8 loc cs
 
 let njunk n = Util.repeat n Stream.junk
 
-let check_utf8_trailing_byte cs c =
-  if not (Int.equal (Char.code c land 0xC0) 0x80) then error_utf8 cs
+let check_utf8_trailing_byte loc cs c =
+  if not (Int.equal (Char.code c land 0xC0) 0x80) then error_utf8 loc 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 lookup_utf8_tail loc c cs =
   let c1 = Char.code c in
-  if Int.equal (c1 land 0x40) 0 || Int.equal (c1 land 0x38) 0x38 then error_utf8 cs
+  if Int.equal (c1 land 0x40) 0 || Int.equal (c1 land 0x38) 0x38 then error_utf8 loc cs
   else
     let n, unicode =
       if Int.equal (c1 land 0x20) 0 then
       match Stream.npeek 2 cs with
       | [_;c2] ->
-          check_utf8_trailing_byte cs c2;
+          check_utf8_trailing_byte loc cs c2;
           2, (c1 land 0x1F) lsl 6 + (Char.code c2 land 0x3F)
-      | _ -> error_utf8 cs
+      | _ -> error_utf8 loc cs
       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;
+          check_utf8_trailing_byte loc cs c2;
+	  check_utf8_trailing_byte loc cs c3;
           3, (c1 land 0x0F) lsl 12 + (Char.code c2 land 0x3F) lsl 6 +
           (Char.code c3 land 0x3F)
-      | _ -> error_utf8 cs
+      | _ -> error_utf8 loc 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;
+          check_utf8_trailing_byte loc cs c2;
+	  check_utf8_trailing_byte loc cs c3;
+          check_utf8_trailing_byte loc 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
+      | _ -> error_utf8 loc cs
     in
-    try Unicode.classify unicode, n
-    with Unicode.Unsupported ->
-      njunk n cs; error_unsupported_unicode_character n unicode cs
+    Utf8Token (Unicode.classify unicode, n)
 
-let lookup_utf8 cs =
+let lookup_utf8 loc cs =
   match Stream.peek cs with
     | Some ('\x00'..'\x7F') -> AsciiChar
-    | Some ('\x80'..'\xFF' as c) -> Utf8Token (lookup_utf8_tail c cs)
+    | Some ('\x80'..'\xFF' as c) -> lookup_utf8_tail loc c cs
     | None -> EmptyStream
 
 let unlocated f x = f x
@@ -180,20 +186,13 @@ let check_keyword str =
   let rec loop_symb = parser
     | [< ' (' ' | '\n' | '\r' | '\t' | '"') >] -> bad_token str
     | [< s >] ->
-        match unlocated lookup_utf8 s with
+        match unlocated lookup_utf8 Compat.CompatLoc.ghost 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)
 
-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))
-
 let check_ident str =
   let rec loop_id intail = parser
     | [< ' ('a'..'z' | 'A'..'Z' | '_'); s >] ->
@@ -201,7 +200,7 @@ let check_ident str =
     | [< ' ('0'..'9' | ''') when intail; s >] ->
         loop_id true s
     | [< s >] ->
-        match unlocated lookup_utf8 s with
+        match unlocated lookup_utf8 Compat.CompatLoc.ghost s with
         | Utf8Token (Unicode.Letter, n) -> njunk n s; loop_id true s
         | Utf8Token (Unicode.IdentPart, n) when intail ->
           njunk n s;
@@ -224,13 +223,15 @@ let is_keyword s =
 let add_keyword str =
   if not (is_keyword str) then
     begin
-      check_keyword_to_add str;
+      check_keyword str;
       token_tree := ttree_add !token_tree str
     end
 
 let remove_keyword str =
   token_tree := ttree_remove !token_tree str
 
+let keywords () = ttree_elements !token_tree
+
 (* Freeze and unfreeze the state of the lexer *)
 type frozen_t = ttree
 
@@ -254,87 +255,133 @@ let get_buff len = String.sub !buff 0 len
 
 (* The classical lexer: idents, numbers, quoted strings, comments *)
 
-let rec ident_tail len = parser
+let warn_unrecognized_unicode =
+  CWarnings.create ~name:"unrecognized-unicode" ~category:"parsing"
+         (fun (u,id) ->
+          strbrk (Printf.sprintf "Not considering unicode character \"%s\" of unknown \
+                                  lexical status as part of identifier \"%s\"." u id))
+
+let rec ident_tail loc len = parser
   | [< ' ('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_' as c); s >] ->
-      ident_tail (store len c) s
+      ident_tail loc (store len c) s
   | [< s >] ->
-      match lookup_utf8 s with
+      match lookup_utf8 loc s with
       | Utf8Token ((Unicode.IdentPart | Unicode.Letter), n) ->
-          ident_tail (nstore n len s) s
+          ident_tail loc (nstore n len s) s
+      | Utf8Token (Unicode.Unknown, n) ->
+          let id = get_buff len in
+          let u = String.concat "" (List.map (String.make 1) (Stream.npeek n s)) in
+          warn_unrecognized_unicode ~loc:!@loc (u,id); len
       | _ -> len
 
 let rec number len = parser
   | [< ' ('0'..'9' as c); s >] -> number (store len c) s
   | [< >] -> len
 
-let rec string in_comments bp len = parser
+let warn_comment_terminator_in_string =
+  CWarnings.create ~name:"comment-terminator-in-string" ~category:"parsing"
+         (fun () ->
+          (strbrk
+             "Not interpreting \"*)\" as the end of current \
+              non-terminated comment because it occurs in a \
+              non-terminated string of the comment."))
+
+(* If the string being lexed is in a comment, [comm_level] is Some i with i the
+   current level of comments nesting. Otherwise, [comm_level] is None. *)
+let rec string loc ~comm_level bp len = parser
   | [< ''"'; esc=(parser [<''"' >] -> true | [< >] -> false); s >] ->
-      if esc then string in_comments bp (store len '"') s else len
+      if esc then string loc ~comm_level bp (store len '"') s else (loc, len)
   | [< ''('; s >] ->
       (parser
         | [< ''*'; s >] ->
-            string
-              (Option.map succ in_comments)
+            string loc
+              (Option.map succ comm_level)
               bp (store (store len '(') '*')
               s
         | [< >] ->
-            string in_comments bp (store len '(') s) s
+            string loc comm_level bp (store len '(') s) s
   | [< ''*'; s >] ->
       (parser
         | [< '')'; s >] ->
-            let () = match in_comments with
+            let () = match comm_level 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.")
+	       warn_comment_terminator_in_string ~loc:!@loc ()
             | _ -> ()
             in
-            let in_comments = Option.map pred in_comments in
-            string in_comments bp (store (store len '*') ')') s
+            let comm_level = Option.map pred comm_level in
+            string loc comm_level bp (store (store len '*') ')') 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
+            string loc comm_level bp (store len '*') s) s
+  | [< ''\n' as c; s >] ep ->
+     (* If we are parsing a comment, the string if not part of a token so we
+     update the first line of the location. Otherwise, we update the last
+     line. *)
+     let loc =
+       if Option.has_some comm_level then bump_loc_line loc ep
+       else bump_loc_line_last loc ep
+     in
+     string loc comm_level bp (store len c) s
+  | [< 'c; s >] -> string loc comm_level bp (store len c) s
+  | [< _ = Stream.empty >] ep ->
+     let loc = set_loc_pos loc bp ep in
+     err loc Unterminated_string
 
 (* Hook for exporting comment into xml theory files *)
 let (f_xml_output_comment, xml_output_comment) = Hook.make ~default:ignore ()
 
+(* To associate locations to a file name *)
+let current_file = ref None
+
 (* Utilities for comments in beautify *)
 let comment_begin = ref None
 let comm_loc bp = match !comment_begin with
 | None -> comment_begin := Some bp
 | _ -> ()
 
-let current = Buffer.create 8192
-let between_com = ref true
+let comments = ref []
+let current_comment = Buffer.create 8192
+let between_commands = ref true
 
-type com_state = int option * string * bool
-let restore_com_state (o,s,b) =
+let rec split_comments 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_comments (c::comacc) acc pos coms
+      else split_comments comacc (com::acc) pos coms
+
+let extract_comments pos = split_comments [] [] pos !comments
+
+(* The state of the lexer visible from outside *)
+type lexer_state = int option * string * bool * ((int * int) * string) list * string option
+
+let init_lexer_state f = (None,"",true,[],f)
+let set_lexer_state (o,s,b,c,f) =
   comment_begin := o;
-  Buffer.clear current; Buffer.add_string current s;
-  between_com := b
-let dflt_com = (None,"",true)
-let com_state () =
-  let s = (!comment_begin, Buffer.contents current, !between_com) in
-  restore_com_state dflt_com; s
+  Buffer.clear current_comment; Buffer.add_string current_comment s;
+  between_commands := b;
+  comments := c;
+  current_file := f
+let release_lexer_state () =
+  (!comment_begin, Buffer.contents current_comment, !between_commands, !comments, !current_file)
+let drop_lexer_state () =
+    set_lexer_state (init_lexer_state None)
 
-let real_push_char c = Buffer.add_char current c
+let real_push_char c = Buffer.add_char current_comment c
 
 (* Add a char if it is between two commands, if it is a newline or
    if the last char is not a space itself. *)
 let push_char c =
   if
-    !between_com || List.mem c ['\n';'\r'] ||
+    !between_commands || List.mem c ['\n';'\r'] ||
     (List.mem c [' ';'\t']&&
-     (Int.equal (Buffer.length current) 0 ||
-      not (let s = Buffer.contents current in
+     (Int.equal (Buffer.length current_comment) 0 ||
+      not (let s = Buffer.contents current_comment in
            List.mem s.[String.length s - 1] [' ';'\t';'\n';'\r'])))
   then
     real_push_char c
 
-let push_string s = Buffer.add_string current s
+let push_string s = Buffer.add_string current_comment s
 
 let null_comment s =
   let rec null i =
@@ -342,146 +389,134 @@ let null_comment s =
   null (String.length s - 1)
 
 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
+  let current_s = Buffer.contents current_comment in
+  if !Flags.xml_export && Buffer.length current_comment > 0 &&
+    (!between_commands || not(null_comment current_s)) then
       Hook.get f_xml_output_comment current_s;
-  (if Flags.do_beautify() && Buffer.length current > 0 &&
-    (!between_com || not(null_comment current_s)) then
+  (if !Flags.beautify && Buffer.length current_comment > 0 &&
+    (!between_commands || 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);
+          Feedback.msg_notice
+            (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;
+    comments := ((bp,ep),current_s) :: !comments);
+  Buffer.clear current_comment;
   comment_begin := None;
-  between_com := false
-
-(* Does not unescape!!! *)
-let rec comm_string bp = parser
-  | [< ''"' >] -> push_string "\""
-  | [< ''\\'; _ =
-           (parser [< ' ('"' | '\\' as 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
-  | [< 'c; s >] -> real_push_char c; comm_string bp s
-
-let rec comment bp = parser bp2
+  between_commands := false
+
+let rec comment loc bp = parser bp2
   | [< ''(';
-       _ = (parser
-              | [< ''*'; s >] -> push_string "(*"; comment bp s
-              | [< >] -> push_string "(" );
-       s >] -> comment bp s
+       loc = (parser
+              | [< ''*'; s >] -> push_string "(*"; comment loc bp s
+              | [< >] -> push_string "("; loc );
+       s >] -> comment loc bp s
   | [< ''*';
-       _ = parser
-         | [< '')' >] -> push_string "*)";
-         | [< s >] -> real_push_char '*'; comment bp s >] -> ()
+       loc = parser
+         | [< '')' >] -> push_string "*)"; loc
+         | [< s >] -> real_push_char '*'; comment loc bp s >] -> loc
   | [< ''"'; s >] ->
-      if Flags.do_beautify() then (push_string"\"";comm_string bp2 s)
-      else ignore (string (Some 0) bp2 0 s);
-      comment bp s
-  | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_comment
-  | [< 'z; s >] -> real_push_char z; comment bp s
+      let loc, len = string loc ~comm_level:(Some 0) bp2 0 s in
+      push_string "\""; push_string (get_buff len); push_string "\"";
+      comment loc bp s
+  | [< _ = Stream.empty >] ep ->
+      let loc = set_loc_pos loc bp ep in
+      err loc Unterminated_comment
+  | [< ''\n' as z; s >] ep -> real_push_char z; comment (bump_loc_line loc ep) bp s
+  | [< 'z; s >] -> real_push_char z; comment loc bp s
 
 (* Parse a special token, using the [token_tree] *)
 
 (* Peek as much utf-8 lexemes as possible *)
 (* and retain the longest valid special token obtained *)
-let rec progress_further last nj tt cs =
-  try progress_from_byte last nj tt cs (List.nth (Stream.npeek (nj+1) cs) nj)
+let rec progress_further loc last nj tt cs =
+  try progress_from_byte loc last nj tt cs (List.nth (Stream.npeek (nj+1) cs) nj)
   with Failure _ -> last
 
-and update_longest_valid_token last nj tt cs =
+and update_longest_valid_token loc last nj tt cs =
   match tt.node with
   | Some _ as last' ->
     stream_njunk nj cs;
-    progress_further last' 0 tt cs
+    progress_further loc last' 0 tt cs
   | None ->
-    progress_further last nj tt cs
+    progress_further loc 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 =
+and progress_utf8 loc last nj n c tt cs =
   try
     let tt = CharMap.find c tt.branch in
     if Int.equal n 1 then
-      update_longest_valid_token last (nj+n) tt cs
+      update_longest_valid_token loc last (nj+n) tt cs
     else
       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;
+         List.iter (check_utf8_trailing_byte loc 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
+         update_longest_valid_token loc last (nj+n) tt cs
       | _ ->
-          error_utf8 cs
+          error_utf8 loc cs
   with Not_found ->
     last
 
-and progress_from_byte last nj tt cs c =
-  progress_utf8 last nj (utf8_char_size cs c) c tt cs
+and progress_from_byte loc last nj tt cs c =
+  progress_utf8 loc last nj (utf8_char_size loc cs c) c tt cs
 
-let find_keyword id s =
+let find_keyword loc id s =
   let tt = ttree_find !token_tree id in
-  match progress_further tt.node 0 tt s with
+  match progress_further loc tt.node 0 tt s with
   | None -> raise Not_found
   | Some c -> KEYWORD c
 
-let process_sequence bp c cs =
+let process_sequence loc 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)
+    | _ -> BULLET (String.make n c), set_loc_pos loc 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
+let process_chars loc bp c cs =
+  let t = progress_from_byte loc None (-1) !token_tree cs c in
   let ep = Stream.count cs in
   match t with
-    | Some t -> (KEYWORD t, (bp, ep))
+    | Some t -> (KEYWORD t, set_loc_pos loc bp ep)
     | None ->
-        let ep' = bp + utf8_char_size cs c in
+        let ep' = bp + utf8_char_size loc cs c in
         njunk (ep' - ep) cs;
-        err (bp, ep') Undefined_token
-
-let token_of_special c s = match c with
-  | '$' -> METAIDENT s
-  | '.' -> FIELD s
-  | _ -> assert false
+	let loc = set_loc_pos loc bp ep' in
+        err loc Undefined_token
 
-(* Parse what follows a dot / a dollar *)
+(* Parse what follows a dot *)
 
-let parse_after_special c bp =
+let parse_after_dot loc c bp =
   parser
-  | [< ' ('a'..'z' | 'A'..'Z' | '_' as d); len = ident_tail (store 0 d) >] ->
-      token_of_special c (get_buff len)
+  | [< ' ('a'..'z' | 'A'..'Z' | '_' as d); len = ident_tail loc (store 0 d); s >] ->
+      let field = get_buff len in
+      (try find_keyword loc ("."^field) s with Not_found -> FIELD field)
   | [< s >] ->
-      match lookup_utf8 s with
+      match lookup_utf8 loc s with
       | 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)
+          let len = ident_tail loc (nstore n 0 s) s in
+          let field = get_buff len in
+          (try find_keyword loc ("."^field) s with Not_found -> FIELD field)
+      | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars loc bp c s)
 
 (* Parse what follows a question mark *)
 
-let parse_after_qmark bp s =
+let parse_after_qmark loc bp s =
   match Stream.peek s with
     | Some ('a'..'z' | 'A'..'Z' | '_') -> LEFTQMARK
     | None -> KEYWORD "?"
     | _ ->
-        match lookup_utf8 s with
+        match lookup_utf8 loc s with
           | Utf8Token (Unicode.Letter, _) -> LEFTQMARK
           | AsciiChar | Utf8Token _ | EmptyStream ->
-            fst (process_chars bp '?' s)
+            fst (process_chars loc bp '?' s)
 
 let blank_or_eof cs =
   match Stream.peek cs with
@@ -491,71 +526,76 @@ let blank_or_eof cs =
 
 (* Parse a token in a char stream *)
 
-let rec next_token = parser bp
-  | [< '' ' | '\t' | '\n' |'\r' as c; s >] ->
-      comm_loc bp; push_char c; next_token s
-  | [< ''$' as c; t = parse_after_special c bp >] ep ->
-      comment_stop bp; (t, (ep, bp))
-  | [< ''.' as c; t = parse_after_special c bp; s >] ep ->
+let rec next_token loc = parser bp
+  | [< ''\n' as c; s >] ep ->
+      comm_loc bp; push_char c; next_token (bump_loc_line loc ep) s
+  | [< '' ' | '\t' | '\r' as c; s >] ->
+      comm_loc bp; push_char c; next_token loc s
+  | [< ''.' as c; t = parse_after_dot loc c bp; s >] ep ->
       comment_stop bp;
       (* We enforce that "." should either be part of a larger keyword,
          for instance ".(", or followed by a blank or eof. *)
       let () = match t with
       | KEYWORD ("." | "...") ->
-        if not (blank_or_eof s) then err (bp,ep+1) Undefined_token;
-        between_com := true;
+        if not (blank_or_eof s) then
+	  err (set_loc_pos loc bp (ep+1)) Undefined_token;
+	between_commands := true;
       | _ -> ()
       in
-      (t, (bp,ep))
+      (t, set_loc_pos loc 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
+      let t,new_between_commands =
+        if !between_commands then process_sequence loc bp c s, true
+        else process_chars loc bp c s,false
       in
-      comment_stop bp; between_com := new_between_com; t
+      comment_stop bp; between_commands := new_between_commands; t
   | [< ''?'; s >] ep ->
-      let t = parse_after_qmark bp s in comment_stop bp; (t, (ep, bp))
+      let t = parse_after_qmark loc bp s in
+      comment_stop bp; (t, set_loc_pos loc bp ep)
   | [< ' ('a'..'z' | 'A'..'Z' | '_' as c);
-       len = ident_tail (store 0 c); s >] ep ->
+       len = ident_tail loc (store 0 c); s >] ep ->
       let id = get_buff len in
       comment_stop bp;
-      (try find_keyword id s with Not_found -> IDENT id), (bp, ep)
+      (try find_keyword loc id s with Not_found -> IDENT id), set_loc_pos loc bp ep
   | [< ' ('0'..'9' as c); len = number (store 0 c) >] ep ->
       comment_stop bp;
-      (INT (get_buff len), (bp, ep))
-  | [< ''\"'; len = string None bp 0 >] ep ->
+      (INT (get_buff len), set_loc_pos loc bp ep)
+  | [< ''\"'; (loc,len) = string loc None bp 0 >] ep ->
       comment_stop bp;
-      (STRING (get_buff len), (bp, ep))
+      (STRING (get_buff len), set_loc_pos loc bp ep)
   | [< ' ('(' as c);
       t = parser
         | [< ''*'; s >] ->
             comm_loc bp;
             push_string "(*";
-            comment bp s;
-            next_token s
-        | [< t = process_chars bp c >] -> comment_stop bp; t >] ->
+            let loc = comment loc bp s in next_token loc s
+        | [< t = process_chars loc bp c >] -> comment_stop bp; t >] ->
       t
+  | [< ' ('{' | '}' as c); s >] ep ->
+      let t,new_between_commands =
+        if !between_commands then (KEYWORD (String.make 1 c), set_loc_pos loc bp ep), true
+        else process_chars loc bp c s, false
+      in
+      comment_stop bp; between_commands := new_between_commands; t
   | [< s >] ->
-      match lookup_utf8 s with
+      match lookup_utf8 loc s with
         | Utf8Token (Unicode.Letter, n) ->
-            let len = ident_tail (nstore n 0 s) s in
+            let len = ident_tail loc (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
+            (try find_keyword loc id s with Not_found -> IDENT id), set_loc_pos loc bp ep
+        | AsciiChar | Utf8Token ((Unicode.Symbol | Unicode.IdentPart | Unicode.Unknown), _) ->
+            let t = process_chars loc bp (Stream.next s) s in
+            comment_stop bp; t
         | EmptyStream ->
-            comment_stop bp; (EOI, (bp, bp + 1))
+            comment_stop bp; (EOI, set_loc_pos loc bp (bp+1))
 
 (* (* Debug: uncomment this for tracing tokens seen by coq...*)
-let next_token s =
-  let (t,(bp,ep)) = next_token s in Printf.eprintf "[%s]\n%!" (Tok.to_string t);
-  (t,(bp,ep))
-*)
+let next_token loc s =
+  let (t,loc as r) = next_token loc s in
+  Printf.eprintf "(line %i, %i-%i)[%s]\n%!" (Ploc.line_nb loc) (Ploc.first_pos loc) (Ploc.last_pos loc) (Tok.to_string t);
+  r *)
 
 (* Location table system for creating tables associating a token count
    to its location in a char stream (the source) *)
@@ -569,12 +609,6 @@ let loct_func loct i =
 
 let loct_add loct i loc = Hashtbl.add loct i loc
 
-let current_location_table = ref (loct_create ())
-
-type location_table = (int, CompatLoc.t) Hashtbl.t
-let location_table () = !current_location_table
-let restore_location_table t = current_location_table := t
-
 (** {6 The lexer of Coq} *)
 
 (** Note: removing a token.
@@ -604,13 +638,14 @@ let token_text = function
 
 let func cs =
   let loct = loct_create () in
+  let cur_loc = ref (Compat.make_loc !current_file 1 0 0 0) in
   let ts =
     Stream.from
       (fun i ->
-         let (tok, loc) = next_token cs in
-         loct_add loct i (make_loc loc); Some tok)
+         let (tok, loc) = next_token !cur_loc cs in
+	 cur_loc := Compat.after loc;
+         loct_add loct i loc; Some tok)
   in
-  current_location_table := loct;
   (ts, loct_func loct)
 
 let lexer = {
@@ -628,10 +663,10 @@ ELSE (* official camlp4 for ocaml >= 3.10 *)
 
 module M_ = Camlp4.ErrorHandler.Register (Error)
 
-module Loc = CompatLoc
+module Loc = Compat.CompatLoc
 module Token = struct
   include Tok (* Cf. tok.ml *)
-  module Loc = CompatLoc
+  module Loc = Compat.CompatLoc
   module Error = Camlp4.Struct.EmptyError
   module Filter = struct
     type token_filter = (Tok.t * Loc.t) Stream.t -> (Tok.t * Loc.t) Stream.t
@@ -644,16 +679,18 @@ module Token = struct
   end
 end
 
-let mk () _init_loc(*FIXME*) cs =
+let mk () =
   let loct = loct_create () in
-  let rec self =
+  let cur_loc = ref (Compat.make_loc !current_file 1 0 0 0) in
+  let rec self init_loc (* FIXME *) =
     parser i
-       [< (tok, loc) = next_token; s >] ->
-          let loc = make_loc loc in
-            loct_add loct i loc;
-            [< '(tok, loc); self s >]
+       [< (tok, loc) = next_token !cur_loc; s >] ->
+            cur_loc := Compat.set_loc_file loc !current_file;
+	    loct_add loct i loc;
+            [< '(tok, loc); self init_loc s >]
       | [< >] -> [< >]
-  in current_location_table := loct; self cs
+  in
+  self
 
 END
 
@@ -689,7 +726,7 @@ let strip s =
 
 let terminal s =
   let s = strip s in
-  let () = match s with "" -> Errors.error "empty token." | _ -> () in
+  let () = match s with "" -> failwith "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/cLexer.mli
index 24b0ec84..e0fdf8cb 100644
--- a/parsing/lexer.mli
+++ b/parsing/cLexer.mli
@@ -9,13 +9,7 @@
 val add_keyword : string -> unit
 val remove_keyword : string -> unit
 val is_keyword : string -> bool
-
-(* val location_function : int -> Loc.t *)
-
-(** for coqdoc *)
-type location_table
-val location_table : unit -> location_table
-val restore_location_table : location_table -> unit
+val keywords : unit -> CString.Set.t
 
 val check_ident : string -> unit
 val is_ident : string -> bool
@@ -25,12 +19,12 @@ type frozen_t
 val freeze : unit -> frozen_t
 val unfreeze : frozen_t -> unit
 
-type com_state
-val com_state: unit -> com_state
-val restore_com_state: com_state -> unit
-
 val xml_output_comment : (string -> unit) Hook.t
 
+(* Retrieve the comments lexed at a given location of the stream
+   currently being processeed *)
+val extract_comments : int -> string list
+
 val terminal : string -> Tok.t
 
 (** The lexer of Coq: *)
diff --git a/parsing/compat.ml4 b/parsing/compat.ml4
index d1d55c81..befa0d01 100644
--- a/parsing/compat.ml4
+++ b/parsing/compat.ml4
@@ -10,6 +10,10 @@
 
 (** Locations *)
 
+let file_loc_of_file = function
+| None -> ""
+| Some f -> f
+
 IFDEF CAMLP5 THEN
 
 module CompatLoc = struct
@@ -20,23 +24,49 @@ end
 
 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)
+  { Loc.fname = Ploc.file_name loc;
+    Loc.line_nb = Ploc.line_nb loc;
+    Loc.bol_pos = Ploc.bol_pos loc;
+    Loc.bp = Ploc.first_pos loc;
+    Loc.ep = Ploc.last_pos loc;
+    Loc.line_nb_last = Ploc.line_nb_last loc;
+    Loc.bol_pos_last = Ploc.bol_pos_last loc; }
+
+let make_loc fname line_nb bol_pos bp ep = Ploc.make_loc (file_loc_of_file fname) line_nb bol_pos (bp, ep) ""
+
+(* Update a loc without allocating an intermediate pair *)
+let set_loc_pos loc bp ep =
+  Ploc.sub loc (bp - Ploc.first_pos loc) (ep - bp)
+
+(* Increase line number by 1 and update position of beginning of line *)
+let bump_loc_line loc bol_pos =
+  Ploc.make_loc (Ploc.file_name loc) (Ploc.line_nb loc + 1) bol_pos
+		(Ploc.first_pos loc, Ploc.last_pos loc) (Ploc.comment loc)
+
+(* Same as [bump_loc_line], but for the last line in location *)
+(* For an obscure reason, camlp5 does not give an easy way to set line_nb_stop,
+   so we have to resort to a hack merging two locations. *)
+(* Warning: [bump_loc_line_last] changes the end position. You may need to call
+   [set_loc_pos] to fix it. *)
+let bump_loc_line_last loc bol_pos =
+  let loc' =
+    Ploc.make_loc (Ploc.file_name loc) (Ploc.line_nb_last loc + 1) bol_pos
+		  (Ploc.first_pos loc + 1, Ploc.last_pos loc + 1) (Ploc.comment loc)
+  in
+  Ploc.encl loc loc'
 
-let make_loc = Ploc.make_unlined
+let set_loc_file loc fname =
+  Ploc.make_loc fname (Ploc.line_nb loc) (Ploc.bol_pos loc)
+		(Ploc.first_pos loc, Ploc.last_pos loc) (Ploc.comment loc)
+
+(* For some reason, the [Ploc.after] function of Camlp5 does not update line
+   numbers, so we define our own function that does it. *)
+let after loc =
+  let line_nb = Ploc.line_nb_last loc in
+  let bol_pos = Ploc.bol_pos_last loc in
+  Ploc.make_loc (Ploc.file_name loc) line_nb bol_pos
+		(Ploc.last_pos loc, Ploc.last_pos loc) (Ploc.comment loc)
 
 ELSE
 
@@ -44,16 +74,39 @@ module CompatLoc = Camlp4.PreCast.Loc
 
 exception Exc_located = CompatLoc.Exc_located
 
-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 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)
+  { Loc.fname = CompatLoc.file_name loc;
+    Loc.line_nb = CompatLoc.start_line loc;
+    Loc.bol_pos = CompatLoc.start_bol loc;
+    Loc.bp = CompatLoc.start_off loc;
+    Loc.ep = CompatLoc.stop_off loc;
+    Loc.line_nb_last = CompatLoc.stop_line loc;
+    Loc.bol_pos_last = CompatLoc.stop_bol loc; }
+
+let make_loc fname line_nb bol_pos start stop =
+  CompatLoc.of_tuple (file_loc_of_file fname, line_nb, bol_pos, start, line_nb, bol_pos, stop, false)
+
+open CompatLoc
+
+let set_loc_pos loc bp ep =
+  of_tuple (file_name loc, start_line loc, start_bol loc, bp,
+	    stop_line loc, stop_bol loc, ep, is_ghost loc)
+
+let bump_loc_line loc bol_pos =
+  of_tuple (file_name loc, start_line loc + 1, bol_pos, start_off loc,
+	    start_line loc + 1, bol_pos, stop_off loc, is_ghost loc)
 
-let make_loc (start, stop) =
-  CompatLoc.of_tuple ("", 0, 0, start, 0, 0, stop, false)
+let bump_loc_line_last loc bol_pos =
+  of_tuple (file_name loc, start_line loc, start_bol loc, start_off loc,
+	    stop_line loc + 1, bol_pos, stop_off loc, is_ghost loc)
+
+let set_loc_file loc fname =
+  of_tuple (file_loc_of_file fname, start_line loc, start_bol loc, start_off loc,
+	    stop_line loc, stop_bol loc, stop_off loc, is_ghost loc)
+
+let after loc =
+  of_tuple (file_name loc, stop_line loc, stop_bol loc, stop_off loc,
+	    stop_line loc, stop_bol loc, stop_off loc, is_ghost loc)
 
 END
 
@@ -65,6 +118,7 @@ IFDEF CAMLP5 THEN
 
 module PcamlSig = struct end
 module Token = Token
+module CompatGramext = struct include Gramext type assoc = g_assoc end
 
 ELSE
 
@@ -73,69 +127,11 @@ module Ast = Camlp4.PreCast.Ast
 module Pcaml = Camlp4.PreCast.Syntax
 module MLast = Ast
 module Token = struct exception Error of string end
+module CompatGramext = Camlp4.Sig.Grammar
 
 END
 
-
-(** Grammar auxiliary types *)
-
-IFDEF CAMLP5 THEN
-
-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
-
-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
-
-
-(** Signature of Lexer *)
+(** Signature of CLexer *)
 
 IFDEF CAMLP5 THEN
 
@@ -146,12 +142,23 @@ module type LexerSig = sig
     exception E of t
     val to_string : t -> string
   end
+  type lexer_state
+  val init_lexer_state : string option -> lexer_state
+  val set_lexer_state : lexer_state -> unit
+  val release_lexer_state : unit -> lexer_state
+  val drop_lexer_state : unit -> unit
 end
 
 ELSE
 
-module type LexerSig =
-  Camlp4.Sig.Lexer with module Loc = CompatLoc and type Token.t = Tok.t
+module type LexerSig = sig
+  include Camlp4.Sig.Lexer with module Loc = CompatLoc and type Token.t = Tok.t
+  type lexer_state
+  val init_lexer_state : string option -> lexer_state
+  val set_lexer_state : lexer_state -> unit
+  val release_lexer_state : unit -> lexer_state
+  val drop_lexer_state : unit -> unit
+end
 
 END
 
@@ -170,10 +177,13 @@ module type GrammarSig = sig
       string option * Gramext.g_assoc option * production_rule list
   type extend_statment =
       Gramext.position option * single_extend_statment list
+  type coq_parsable
+  val parsable : ?file:string -> char Stream.t -> coq_parsable
   val action : 'a -> action
   val entry_create : string -> 'a entry
-  val entry_parse : 'a entry -> parsable -> 'a
+  val entry_parse : 'a entry -> coq_parsable -> 'a
   val entry_print : Format.formatter -> 'a entry -> unit
+  val with_parsable : coq_parsable -> ('a -> 'b) -> 'a -> 'b
   val srules' : production_rule list -> symbol
   val parse_tokens_after_filter : 'a entry -> Tok.t Stream.t -> 'a
 end
@@ -189,16 +199,37 @@ module GrammarMake (L:LexerSig) : GrammarSig = struct
       string option * Gramext.g_assoc option * production_rule list
   type extend_statment =
       Gramext.position option * single_extend_statment list
+  type coq_parsable = parsable * L.lexer_state ref
+  let parsable ?file c =
+    let state = ref (L.init_lexer_state file) in
+    L.set_lexer_state !state;
+    let a = parsable c in
+    state := L.release_lexer_state ();
+    (a,state)
   let action = Gramext.action
   let entry_create = Entry.create
-  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_parse e (p,state) =
+    L.set_lexer_state !state;
+    try
+      let c = Entry.parse e p in
+      state := L.release_lexer_state ();
+      c
+    with Exc_located (loc,e) ->
+      L.drop_lexer_state ();
+      let loc' = Loc.get_loc (Exninfo.info e) in
+      let loc = match loc' with None -> to_coqloc loc | Some loc -> loc in
+      Loc.raise loc e
+  let with_parsable (p,state) f x =
+    L.set_lexer_state !state;
+    try
+      let a = f x in
+      state := L.release_lexer_state ();
+      a
+    with e ->
+      L.drop_lexer_state ();
+      raise e
+
   let entry_print ft x = Entry.print ft x
-ELSE
-  let entry_print _ x = Entry.print x
-END
   let srules' = Gramext.srules
   let parse_tokens_after_filter = Entry.parse_token
 end
@@ -210,12 +241,13 @@ module type GrammarSig = sig
     with module Loc = CompatLoc and type Token.t = Tok.t
   type 'a entry = 'a Entry.t
   type action = Action.t
-  type parsable
-  val parsable : char Stream.t -> parsable
+  type coq_parsable
+  val parsable : ?file:string -> char Stream.t -> coq_parsable
   val action : 'a -> action
   val entry_create : string -> 'a entry
-  val entry_parse : 'a entry -> parsable -> 'a
+  val entry_parse : 'a entry -> coq_parsable -> 'a
   val entry_print : Format.formatter -> 'a entry -> unit
+  val with_parsable : coq_parsable -> ('a -> 'b) -> 'a -> 'b
   val srules' : production_rule list -> symbol
 end
 
@@ -225,19 +257,96 @@ module GrammarMake (L:LexerSig) : GrammarSig = struct
   include Camlp4.Struct.Grammar.Static.Make (L)
   type 'a entry = 'a Entry.t
   type action = Action.t
-  type parsable = char Stream.t
-  let parsable s = s
+  type coq_parsable = char Stream.t * L.lexer_state ref
+  let parsable ?file s = let state = ref (L.init_lexer_state file) in (s, state)
   let action = Action.mk
   let entry_create = Entry.mk
-  let entry_parse e s =
-    try parse e (*FIXME*)CompatLoc.ghost s
-    with Exc_located (loc,e) -> raise_coq_loc loc e
+  let entry_parse e (s,state) =
+    L.set_lexer_state !state;
+    try
+      let c = parse e (*FIXME*)CompatLoc.ghost s in
+      state := L.release_lexer_state ();
+      c
+    with Exc_located (loc,e) ->
+      L.drop_lexer_state ();
+      raise_coq_loc loc e;;
+  let with_parsable (p,state) f x =
+    L.set_lexer_state !state;
+    try
+      let a = f x in
+      state := L.release_lexer_state ();
+      a
+    with e ->
+      L.drop_lexer_state ();
+      Pervasives.raise e;;
   let entry_print ft x = Entry.print ft x
   let srules' = srules (entry_create "dummy")
 end
 
 END
 
+(** Some definitions are grammar-specific in Camlp4, so we use a functor to
+    depend on it while taking a dummy argument in Camlp5. *)
+
+module GramextMake (G : GrammarSig) :
+sig
+  val stoken : Tok.t -> G.symbol
+  val sself : G.symbol
+  val snext : G.symbol
+  val slist0 : G.symbol -> G.symbol
+  val slist0sep : G.symbol * G.symbol -> G.symbol
+  val slist1 : G.symbol -> G.symbol
+  val slist1sep : G.symbol * G.symbol -> G.symbol
+  val sopt : G.symbol -> G.symbol
+  val snterml : G.internal_entry * string -> G.symbol
+  val snterm : G.internal_entry -> G.symbol
+  val snterml_level : G.symbol -> string
+end =
+struct
+
+IFDEF CAMLP5 THEN
+  let stoken tok =
+    let pattern = match tok with
+    | Tok.KEYWORD s -> "", s
+    | Tok.IDENT s -> "IDENT", s
+    | Tok.PATTERNIDENT s -> "PATTERNIDENT", s
+    | Tok.FIELD s -> "FIELD", s
+    | Tok.INT s -> "INT", s
+    | Tok.STRING s -> "STRING", s
+    | Tok.LEFTQMARK -> "LEFTQMARK", ""
+    | Tok.BULLET s -> "BULLET", s
+    | Tok.EOI -> "EOI", ""
+    in
+    Gramext.Stoken pattern
+ELSE
+  module Gramext = G
+  let stoken tok = match tok with
+  | Tok.KEYWORD s -> Gramext.Skeyword s
+  | tok -> Gramext.Stoken (Tok.equal tok, G.Token.to_string tok)
+END
+
+  IFDEF CAMLP5 THEN
+     let slist0sep (x, y) = Gramext.Slist0sep (x, y, false)
+     let slist1sep (x, y) = Gramext.Slist1sep (x, y, false)
+  ELSE
+    let slist0sep (x, y) = Gramext.Slist0sep (x, y)
+    let slist1sep (x, y) = Gramext.Slist1sep (x, y)
+  END
+
+  let snterml (x, y) = Gramext.Snterml (x, y)
+  let snterm x = Gramext.Snterm x
+  let sself = Gramext.Sself
+  let snext = Gramext.Snext
+  let slist0 x = Gramext.Slist0 x
+  let slist1 x = Gramext.Slist1 x
+  let sopt x = Gramext.Sopt x
+
+  let snterml_level = function
+  | Gramext.Snterml (_, l) -> l
+  | _ -> failwith "snterml_level"
+
+end
+
 
 (** Misc functional adjustments *)
 
@@ -303,23 +412,10 @@ let make_fun loc cl =
 
 END
 
-(** Explicit antiquotation $anti:... $ *)
-
-IFDEF CAMLP5 THEN
-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$ >>
+let warning_verbose = Gramext.warning_verbose
 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)
+(* TODO: this is a workaround, since there isn't such
+   [warning_verbose] in new camlp4. *)
+let warning_verbose = ref true
 END
diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml
index b0bbdd81..a292c746 100644
--- a/parsing/egramcoq.ml
+++ b/parsing/egramcoq.ml
@@ -6,17 +6,145 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Compat
-open Errors
+open CErrors
 open Util
 open Pcoq
-open Extend
 open Constrexpr
+open Notation
 open Notation_term
+open Extend
 open Libnames
-open Tacexpr
 open Names
-open Egramml
+
+(**********************************************************************)
+(* This determines (depending on the associativity of the current
+   level and on the expected associativity) if a reference to constr_n is
+   a reference to the current level (to be translated into "SELF" on the
+   left border and into "constr LEVEL n" elsewhere), to the level below
+   (to be translated into "NEXT") or to an below wrt associativity (to be
+   translated in camlp4 into "constr" without level) or to another level
+   (to be translated into "constr LEVEL n")
+
+   The boolean is true if the entry was existing _and_ empty; this to
+   circumvent a weakness of camlp4/camlp5 whose undo mechanism is not the
+   converse of the extension mechanism *)
+
+let constr_level = string_of_int
+
+let default_levels =
+  [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,Extend.RightA,true;
+   100,Extend.RightA,false;
+   99,Extend.RightA,true;
+   11,Extend.LeftA,false;
+   10,Extend.RightA,false;
+   1,Extend.LeftA,false;
+   0,Extend.RightA,false]
+
+let default_constr_levels = (default_levels, default_pattern_levels)
+
+(* 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 *)
+
+let admissible_assoc = function
+  | Extend.LeftA, Some (Extend.RightA | Extend.NonA) -> false
+  | Extend.RightA, Some Extend.LeftA -> false
+  | _ -> true
+
+let create_assoc = function
+  | None -> Extend.RightA
+  | Some a -> a
+
+let error_level_assoc p current expected =
+  let open Pp in
+  let pr_assoc = function
+    | 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)
+
+type gram_level =
+  gram_position option * gram_assoc option * string option *
+  (** for reinitialization: *) gram_reinit option
+
+let find_position_gen current ensure assoc lev =
+  match lev with
+  | None ->
+      current, (None, None, None, None)
+  | Some n ->
+      let after = ref None in
+      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 Int.equal p n ->
+            if reinit then
+	      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
+	      error_level_assoc p a (Option.get assoc)
+	| l -> after := q; (n,create_assoc assoc,ensure)::l
+      in
+      try
+	let updated = add_level None current in
+	let assoc = create_assoc assoc in
+        begin match !init with
+        | None ->
+	  (* Create the entry *)
+	   updated, (Some (create_pos !after), Some assoc, Some (constr_level n), None)
+        | _ ->
+	  (* The reinit flag has been updated *)
+	   updated, (Some (Extend.Level (constr_level n)), None, None, !init)
+        end
+      with
+	  (* Nothing has changed *)
+          Exit ->
+	    (* Just inherit the existing associativity and name (None) *)
+	    current, (Some (Extend.Level (constr_level n)), None, None, None)
+
+let rec list_mem_assoc_triple x = function
+  | [] -> false
+  | (a,b,c) :: l -> Int.equal a x || list_mem_assoc_triple x l
+
+let register_empty_levels accu forpat levels =
+  let rec filter accu = function
+  | [] -> ([], accu)
+  | n :: rem ->
+    let rem, accu = filter accu rem in
+    let (clev, plev) = accu in
+    let levels = if forpat then plev else clev in
+    if not (list_mem_assoc_triple n levels) then
+      let nlev, ans = find_position_gen levels true None (Some n) in
+      let nlev = if forpat then (clev, nlev) else (nlev, plev) in
+      ans :: rem, nlev
+    else rem, accu
+  in
+  filter accu levels
+
+let find_position accu forpat assoc level =
+  let (clev, plev) = accu in
+  let levels = if forpat then plev else clev in
+  let nlev, ans = find_position_gen levels false assoc level in
+  let nlev = if forpat then (clev, nlev) else (nlev, plev) in
+  (ans, nlev)
 
 (**************************************************************************)
 (*
@@ -45,6 +173,146 @@ open Egramml
 (**********************************************************************)
 (** Declare Notations grammar rules                                   *)
 
+(**********************************************************************)
+(* Binding constr entry keys to entries                               *)
+
+(* 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
+
+let assoc_eq al ar = match al, ar with
+| NonA, NonA
+| RightA, RightA
+| LeftA, 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
+   the result is
+
+     None = SELF
+     Some None = NEXT
+     Some (Some (n,cur)) = constr LEVEL n
+         s.t. if [cur] is set then [n] is the same as the [from] level *)
+let adjust_level assoc from = function
+(* Associativity is None means force the level *)
+  | (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))) ->
+      Some None
+  (* If RightA on the right-hand side, set to the explicit (current) level *)
+  | (NumLevel n,BorderProd (Right,Some 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
+  (* If the expected assoc is the current one, set to SELF *)
+  | (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)) ->
+    begin match a with
+    | LeftA -> Some (Some (n, true))
+    | _ -> Some None
+    end
+  (* None means NEXT *)
+  | (NextLevel,_) -> Some None
+(* Compute production name elsewhere *)
+  | (NumLevel n,InternalProd) ->
+    if from = n + 1 then Some None else Some (Some (n, Int.equal n from))
+
+type _ target =
+| ForConstr : constr_expr target
+| ForPattern : cases_pattern_expr target
+
+type prod_info = production_level * production_position
+
+type (_, _) entry =
+| TTName : ('self, Name.t Loc.located) entry
+| TTReference : ('self, reference) entry
+| TTBigint : ('self, Bigint.bigint) entry
+| TTBinder : ('self, local_binder list) entry
+| TTConstr : prod_info * 'r target -> ('r, 'r) entry
+| TTConstrList : prod_info * Tok.t list * 'r target -> ('r, 'r list) entry
+| TTBinderListT : ('self, local_binder list) entry
+| TTBinderListF : Tok.t list -> ('self, local_binder list list) entry
+
+type _ any_entry = TTAny : ('s, 'r) entry -> 's any_entry
+
+(* This computes the name of the level where to add a new rule *)
+let interp_constr_entry_key : type r. r target -> int -> r Gram.entry * int option =
+  fun forpat level -> match forpat with
+  | ForConstr ->
+    if level = 200 then Constr.binder_constr, None
+    else Constr.operconstr, Some level
+  | ForPattern -> Constr.pattern, Some level
+
+let target_entry : type s. s target -> s Gram.entry = function
+| ForConstr -> Constr.operconstr
+| ForPattern -> Constr.pattern
+
+let is_self from e = match e with
+| (NumLevel n, BorderProd (Right, _ (* Some(NonA|LeftA) *))) -> false
+| (NumLevel n, BorderProd (Left, _)) -> Int.equal from n
+| _ -> false
+
+let is_binder_level from e = match e with
+| (NumLevel 200, (BorderProd (Right, _) | InternalProd)) -> from = 200
+| _ -> false
+
+let make_sep_rules tkl =
+  let rec mkrule : Tok.t list -> unit rules = function
+  | [] -> Rules ({ norec_rule = Stop }, ignore)
+  | tkn :: rem ->
+    let Rules ({ norec_rule = r }, f) = mkrule rem in
+    let r = { norec_rule = Next (r, Atoken tkn) } in
+    Rules (r, fun _ -> f)
+  in
+  let r = mkrule (List.rev tkl) in
+  Arules [r]
+
+let symbol_of_target : type s. _ -> _ -> _ -> s target -> (s, s) symbol = fun p assoc from forpat ->
+  if is_binder_level from p then Aentryl (target_entry forpat, 200)
+  else if is_self from p then Aself
+  else
+    let g = target_entry forpat in
+    let lev = adjust_level assoc from p in
+    begin match lev with
+    | None -> Aentry g
+    | Some None -> Anext
+    | Some (Some (lev, cur)) -> Aentryl (g, lev)
+    end
+
+let symbol_of_entry : type s r. _ -> _ -> (s, r) entry -> (s, r) symbol = fun assoc from typ -> match typ with
+| TTConstr (p, forpat) -> symbol_of_target p assoc from forpat
+| TTConstrList (typ', [], forpat) ->
+  Alist1 (symbol_of_target typ' assoc from forpat)
+| TTConstrList (typ', tkl, forpat) ->
+  Alist1sep (symbol_of_target typ' assoc from forpat, make_sep_rules tkl)
+| TTBinderListF [] -> Alist1 (Aentry Constr.binder)
+| TTBinderListF tkl -> Alist1sep (Aentry Constr.binder, make_sep_rules tkl)
+| TTName -> Aentry Prim.name
+| TTBinder -> Aentry Constr.binder
+| TTBinderListT -> Aentry Constr.open_binders
+| TTBigint -> Aentry Prim.bigint
+| TTReference -> Aentry Constr.global
+
+let interp_entry forpat e = match e with
+| ETName -> TTAny TTName
+| ETReference -> TTAny TTReference
+| ETBigint -> TTAny TTBigint
+| ETBinder true -> anomaly (Pp.str "Should occur only as part of BinderList")
+| ETBinder false  -> TTAny TTBinder
+| ETConstr p -> TTAny (TTConstr (p, forpat))
+| ETPattern -> assert false (** not used *)
+| ETOther _ -> assert false (** not used *)
+| ETConstrList (p, tkl) -> TTAny (TTConstrList (p, tkl, forpat))
+| ETBinderList (true, []) -> TTAny TTBinderListT
+| ETBinderList (true, _) -> assert false
+| ETBinderList (false, tkl) -> TTAny (TTBinderListF tkl)
+
 let constr_expr_of_name (loc,na) = match na with
   | Anonymous -> CHole (loc,None,Misctypes.IntroAnonymous,None)
   | Name id -> CRef (Ident (loc,id), None)
@@ -53,333 +321,158 @@ let cases_pattern_expr_of_name (loc,na) = match na with
   | Anonymous -> CPatAtom (loc,None)
   | Name id -> CPatAtom (loc,Some (Ident (loc,id)))
 
-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 *)
-
-let make_constr_action
-  (f : Loc.t -> constr_notation_substitution -> constr_expr) pil =
-  let rec make (constrs,constrlists,binders as fullsubst) = function
-  | [] ->
-      Gram.action (fun (loc:CompatLoc.t) -> f (!@loc) fullsubst)
-  | (GramConstrTerminal _ | GramConstrNonTerminal (_,None)) :: tl ->
-      (* parse a non-binding item *)
-      Gram.action (fun _ -> make fullsubst tl)
-  | GramConstrNonTerminal (typ, Some _) :: tl ->
-      (* parse a binding non-terminal *)
-    (match typ with
-    | (ETConstr _| ETOther _) ->
-	Gram.action (fun (v:constr_expr) ->
-	  make (v :: constrs, constrlists, binders) tl)
-    | ETReference ->
-        Gram.action (fun (v:reference) ->
-	  make (CRef (v,None) :: constrs, constrlists, binders) tl)
-    | ETName ->
-        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(Loc.ghost,Numeral v) :: constrs, constrlists, binders) tl)
-    | ETConstrList (_,n) ->
-	Gram.action (fun (v:constr_expr list) ->
-	  make (constrs, v::constrlists, binders) tl)
-    | ETBinder _ | ETBinderList (true,_) ->
-	Gram.action (fun (v:local_binder list) ->
-	  make (constrs, constrlists, v::binders) tl)
-    | ETBinderList (false,_) ->
-	Gram.action (fun (v:local_binder list list) ->
-	  make (constrs, constrlists, List.flatten v::binders) tl)
-    | ETPattern ->
-	failwith "Unexpected entry of type cases pattern")
-  | GramConstrListMark (n,b) :: tl ->
-      (* Rebuild expansions of ConstrList *)
-      let heads,constrs = List.chop n constrs in
-      let constrlists =
-	if b then (heads@List.hd constrlists)::List.tl constrlists
-	else heads::constrlists
-      in make (constrs, constrlists, binders) tl
-  in
-  make ([],[],[]) (List.rev pil)
-
-let check_cases_pattern_env loc (env,envlist,hasbinders) =
-  if hasbinders then Topconstr.error_invalid_pattern_notation loc
-  else (env,envlist)
-
-let make_cases_pattern_action
-  (f : Loc.t -> cases_pattern_notation_substitution -> cases_pattern_expr) pil =
-  let rec make (env,envlist,hasbinders as fullenv) = function
-  | [] ->
-      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)
-  | GramConstrNonTerminal (typ, Some _) :: tl ->
-      (* parse a binding non-terminal *)
-    (match typ with
-    | ETConstr _ -> (* pattern non-terminal *)
-        Gram.action (fun (v:cases_pattern_expr) ->
-          make (v::env, envlist, hasbinders) tl)
-    | ETReference ->
-        Gram.action (fun (v:reference) ->
-	  make (CPatAtom (Loc.ghost,Some v) :: env, envlist, hasbinders) tl)
-    | ETName ->
-        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 (Loc.ghost,Numeral v) :: env, envlist, hasbinders) tl)
-    | ETConstrList (_,_) ->
-        Gram.action  (fun (vl:cases_pattern_expr list) ->
-	  make (env, vl :: envlist, hasbinders) tl)
-    | ETBinder _ | ETBinderList (true,_) ->
-	Gram.action (fun (v:local_binder list) ->
-	  make (env, envlist, hasbinders) tl)
-    | ETBinderList (false,_) ->
-	Gram.action (fun (v:local_binder list list) ->
-	  make (env, envlist, true) tl)
-    | (ETPattern | ETOther _) ->
-        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
-      if b then
-        make (env,(heads@List.hd envlist)::List.tl envlist,hasbinders) tl
-      else
-        make (env,heads::envlist,hasbinders) tl
-  in
-  make ([],[],false) (List.rev pil)
-
-let rec make_constr_prod_item assoc from forpat = function
-  | GramConstrTerminal tok :: l ->
-      gram_token_of_token tok :: make_constr_prod_item assoc from forpat l
-  | GramConstrNonTerminal (nt, ovar) :: l ->
-      symbol_of_constr_prod_entry_key assoc from forpat nt
-      :: make_constr_prod_item assoc from forpat l
-  | GramConstrListMark _ :: l ->
-      make_constr_prod_item assoc from forpat l
-  | [] ->
-      []
-
-let prepare_empty_levels forpat (pos,p4assoc,name,reinit) =
-  let entry =
-    if forpat then weaken_entry Constr.pattern
-    else weaken_entry Constr.operconstr in
-  grammar_extend entry reinit (pos,[(name, p4assoc, [])])
-
-let pure_sublevels level 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 (Option.map of_coq_position pos,
-    [(name, Option.map of_coq_assoc p4assoc, [symbs, mkact pt])]);
-  nb_decls) 0 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 nb = extend_constr_constr_notation ng in
-  (* Add the notation in cases_pattern *)
-  let nb' = extend_constr_pat_notation ng in
-  nb + nb'
-
-(**********************************************************************)
-(** Grammar declaration for Tactic Notation (Coq level)               *)
-
-let get_tactic_entry n =
-  if Int.equal n 0 then
-    weaken_entry Tactic.simple_tactic, None
-  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 (Extend.Level (string_of_int n))
-  else
-    error ("Invalid Tactic Notation level: "^(string_of_int n)^".")
-
-(**********************************************************************)
-(** State of the grammar extensions                                   *)
-
-type tactic_grammar = {
-  tacgram_level : int;
-  tacgram_prods : grammar_prod_item list;
+type 'r env = {
+  constrs : 'r list;
+  constrlists : 'r list list;
+  binders : (local_binder list * bool) 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 (None ,[(None, None, List.rev rules)]);
-  1
-
-(* Declaration of the tactic grammar rule *)
-
-let head_is_ident tg = match tg.tacgram_prods with
-| GramTerminal _::_ -> true
-| _ -> false
-
-(** 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 (kn, g) -> add_tactic_entry kn g
-  | MLTacticGrammar (name, pr) -> add_ml_tactic_entry name pr
+let push_constr subst v = { subst with constrs = v :: subst.constrs }
+
+let push_item : type s r. s target -> (s, r) entry -> s env -> r -> s env = fun forpat e subst v ->
+match e with
+| TTConstr _ -> push_constr subst v
+| TTName ->
+  begin match forpat with
+  | ForConstr -> push_constr subst (constr_expr_of_name v)
+  | ForPattern -> push_constr subst (cases_pattern_expr_of_name v)
+  end
+| TTBinder -> { subst with binders = (v, true) :: subst.binders }
+| TTBinderListT -> { subst with binders = (v, true) :: subst.binders }
+| TTBinderListF _ -> { subst with binders = (List.flatten v, false) :: subst.binders }
+| TTBigint ->
+  begin match forpat with
+  | ForConstr -> push_constr subst (CPrim (Loc.ghost, Numeral v))
+  | ForPattern -> push_constr subst (CPatPrim (Loc.ghost, Numeral v))
+  end
+| TTReference ->
+  begin match forpat with
+  | ForConstr -> push_constr subst (CRef (v, None))
+  | ForPattern -> push_constr subst (CPatAtom (Loc.ghost, Some v))
+  end
+| TTConstrList _ -> { subst with constrlists = v :: subst.constrlists }
+
+type (_, _) ty_symbol =
+| TyTerm : Tok.t -> ('s, string) ty_symbol
+| TyNonTerm : 's target * ('s, 'a) entry * ('s, 'a) symbol * bool -> ('s, 'a) ty_symbol
+
+type ('self, _, 'r) ty_rule =
+| TyStop : ('self, 'r, 'r) ty_rule
+| TyNext : ('self, 'a, 'r) ty_rule * ('self, 'b) ty_symbol -> ('self, 'b -> 'a, 'r) ty_rule
+| TyMark : int * bool * ('self, 'a, 'r) ty_rule -> ('self, 'a, 'r) ty_rule
+
+type 'r gen_eval = Loc.t -> 'r env -> 'r
+
+let rec ty_eval : type s a. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> s env -> a = function
+| TyStop ->
+  fun f env loc -> f loc env
+| TyNext (rem, TyTerm _) ->
+  fun f env _ -> ty_eval rem f env
+| TyNext (rem, TyNonTerm (_, _, _, false)) ->
+  fun f env _ -> ty_eval rem f env
+| TyNext (rem, TyNonTerm (forpat, e, _, true)) ->
+  fun f env v ->
+    ty_eval rem f (push_item forpat e env v)
+| TyMark (n, b, rem) ->
+  fun f env ->
+    let heads, constrs = List.chop n env.constrs in
+    let constrlists =
+      if b then (heads @ List.hd env.constrlists) :: List.tl env.constrlists
+      else heads :: env.constrlists
+    in
+    ty_eval rem f { env with constrs; constrlists; } 
+
+let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = function
+| TyStop -> Stop
+| TyMark (_, _, r) -> ty_erase r
+| TyNext (rem, TyTerm tok) -> Next (ty_erase rem, Atoken tok)
+| TyNext (rem, TyNonTerm (_, _, s, _)) -> Next (ty_erase rem, s)
+
+type ('self, 'r) any_ty_rule =
+| AnyTyRule : ('self, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule
+
+let make_ty_rule assoc from forpat prods =
+  let rec make_ty_rule = function
+  | [] -> AnyTyRule TyStop
+  | GramConstrTerminal tok :: rem ->
+    let AnyTyRule r = make_ty_rule rem in
+    AnyTyRule (TyNext (r, TyTerm tok))
+  | GramConstrNonTerminal (e, var) :: rem ->
+    let AnyTyRule r = make_ty_rule rem in
+    let TTAny e = interp_entry forpat e in
+    let s = symbol_of_entry assoc from e in
+    let bind = match var with None -> false | Some _ -> true in
+    AnyTyRule (TyNext (r, TyNonTerm (forpat, e, s, bind)))
+  | GramConstrListMark (n, b) :: rem ->
+    let AnyTyRule r = make_ty_rule rem in
+    AnyTyRule (TyMark (n, b, r))
   in
-  grammar_state := (nb,gram) :: !grammar_state
+  make_ty_rule (List.rev prods)
 
-let extend_constr_grammar pr ntn =
-  extend_grammar (Notation (pr, ntn))
+let target_to_bool : type r. r target -> bool = function
+| ForConstr -> false
+| ForPattern -> true
 
-let extend_tactic_grammar kn ntn =
-  extend_grammar (TacticGrammar (kn, ntn))
+let prepare_empty_levels forpat (pos,p4assoc,name,reinit) =
+  let empty = (pos, [(name, p4assoc, [])]) in
+  if forpat then ExtendRule (Constr.pattern, reinit, empty)
+  else ExtendRule (Constr.operconstr, reinit, empty)
+
+let rec pure_sublevels : type a b c. int option -> (a, b, c) rule -> int list = fun level r -> match r with
+| Stop -> []
+| Next (rem, Aentryl (_, i)) ->
+  let rem = pure_sublevels level rem in
+  begin match level with
+  | Some j when Int.equal i j -> rem
+  | _ -> i :: rem
+  end
+| Next (rem, _) -> pure_sublevels level rem
+
+let make_act : type r. r target -> _ -> r gen_eval = function
+| ForConstr -> fun notation loc env ->
+  let env = (env.constrs, env.constrlists, List.map fst env.binders) in
+  CNotation (loc, notation , env)
+| ForPattern -> fun notation loc env ->
+  let invalid = List.exists (fun (_, b) -> not b) env.binders in
+  let () = if invalid then Topconstr.error_invalid_pattern_notation loc in
+  let env = (env.constrs, env.constrlists) in
+  CPatNotation (loc, notation, env, [])
+
+let extend_constr state forpat ng =
+  let n = ng.notgram_level in
+  let assoc = ng.notgram_assoc in
+  let (entry, level) = interp_constr_entry_key forpat n in
+  let fold (accu, state) pt =
+    let AnyTyRule r = make_ty_rule assoc n forpat pt in
+    let symbs = ty_erase r in
+    let pure_sublevels = pure_sublevels level symbs in
+    let isforpat = target_to_bool forpat in
+    let needed_levels, state = register_empty_levels state isforpat pure_sublevels in
+    let (pos,p4assoc,name,reinit), state = find_position state isforpat assoc level in
+    let empty_rules = List.map (prepare_empty_levels isforpat) needed_levels in
+    let empty = { constrs = []; constrlists = []; binders = [] } in
+    let act = ty_eval r (make_act forpat ng.notgram_notation) empty in
+    let rule = (name, p4assoc, [Rule (symbs, act)]) in
+    let r = ExtendRule (entry, reinit, (pos, [rule])) in
+    (accu @ empty_rules @ [r], state)
+  in
+  List.fold_left fold ([], state) ng.notgram_prods
 
-let extend_ml_tactic_grammar name ntn =
-  extend_grammar (MLTacticGrammar (name, ntn))
+let constr_levels = GramState.field ()
 
-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
+let extend_constr_notation (_, ng) state =
+  let levels = match GramState.get state constr_levels with
+  | None -> default_constr_levels
+  | Some lev -> lev
   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 = (int * all_grammar_command) list * Lexer.frozen_t
-
-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
-
-let number_of_entries gcl =
-  List.fold_left (fun n (p,_) -> n + p) 0 gcl
-
-let unfreeze (grams, lex) =
-  let (undo, redo, common) = factorize_grams !grammar_state grams in
-  let n = number_of_entries undo in
-  remove_grammars n;
-  remove_levels n;
-  grammar_state := common;
-  Lexer.unfreeze lex;
-  List.iter extend_grammar (List.rev_map snd redo)
-
-(** 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 _ =
-  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 false in
-  try let a = f x in unfreeze fs; a
-  with reraise ->
-    let reraise = Errors.push reraise in
-    let () = unfreeze fs in
-    iraise reraise
-
-(**********************************************************************)
-(** Ltac quotations                                                   *)
+  (* Add the notation in constr *)
+  let (r, levels) = extend_constr levels ForConstr ng in
+  (* Add the notation in cases_pattern *)
+  let (r', levels) = extend_constr levels ForPattern ng in
+  let state = GramState.set state constr_levels levels in
+  (r @ r', state)
 
-let ltac_quotations = ref String.Set.empty
+let constr_grammar : (Notation.level * notation_grammar) grammar_command =
+  create_grammar_command "Notation" extend_constr_notation
 
-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])
+let extend_constr_grammar pr ntn = extend_grammar_command constr_grammar (pr, ntn)
diff --git a/parsing/egramcoq.mli b/parsing/egramcoq.mli
index 964bd541..6dda3817 100644
--- a/parsing/egramcoq.mli
+++ b/parsing/egramcoq.mli
@@ -19,51 +19,7 @@ open Egramml
 (** 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
+val extend_constr_grammar : Notation.level -> Notation_term.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/egramml.ml b/parsing/egramml.ml
index 3896970c..97a3e89a 100644
--- a/parsing/egramml.ml
+++ b/parsing/egramml.ml
@@ -7,41 +7,60 @@
 (************************************************************************)
 
 open Util
-open Compat
-open Names
+open Extend
 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 =
+type 's grammar_prod_item =
   | GramTerminal of string
-  | GramNonTerminal of
-      Loc.t * argument_type * prod_entry_key * Id.t option
+  | GramNonTerminal :
+      Loc.t * 'a raw_abstract_argument_type * ('s, 'a) symbol -> 's grammar_prod_item
+
+type 'a ty_arg = ('a -> raw_generic_argument)
+
+type ('self, _, 'r) ty_rule =
+| TyStop : ('self, 'r, 'r) ty_rule
+| TyNext : ('self, 'a, 'r) ty_rule * ('self, 'b) Extend.symbol * 'b ty_arg option ->
+  ('self, 'b -> 'a, 'r) ty_rule
+
+type ('self, 'r) any_ty_rule =
+| AnyTyRule : ('self, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule
+
+let rec ty_rule_of_gram = function
+| [] -> AnyTyRule TyStop
+| GramTerminal s :: rem ->
+  let AnyTyRule rem = ty_rule_of_gram rem in
+  let tok = Atoken (CLexer.terminal s) in
+  let r = TyNext (rem, tok, None) in
+  AnyTyRule r
+| GramNonTerminal (_, t, tok) :: rem ->
+  let AnyTyRule rem = ty_rule_of_gram rem in
+  let inj = Some (fun obj -> Genarg.in_gen t obj) in
+  let r = TyNext (rem, tok, inj) in
+  AnyTyRule r
+
+let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = function
+| TyStop -> Extend.Stop
+| TyNext (rem, tok, _) -> Extend.Next (ty_erase rem, tok)
+
+type 'r gen_eval = Loc.t -> raw_generic_argument list -> 'r
 
-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 rec ty_eval : type s a. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function
+| TyStop -> fun f loc -> f loc []
+| TyNext (rem, tok, None) -> fun f _ -> ty_eval rem f
+| TyNext (rem, tok, Some inj) -> fun f x ->
+  let f loc args = f loc (inj x :: args) in
+  ty_eval rem f
 
-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)
+let make_rule f prod =
+  let AnyTyRule ty_rule = ty_rule_of_gram (List.rev prod) in
+  let symb = ty_erase ty_rule in
+  let f loc l = f loc (List.rev l) in
+  let act = ty_eval ty_rule f in
+  Extend.Rule (symb, act)
 
 (** Vernac grammar extensions *)
 
@@ -58,6 +77,6 @@ let get_extend_vernac_rule (s, i) =
 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 mkact loc l = VernacExtend (s, l) in
   let rules = [make_rule mkact gl] in
-  maybe_uncurry (Gram.extend nt) (None,[(None, None, List.rev rules)])
+  grammar_extend nt None (None, [None, None, rules])
diff --git a/parsing/egramml.mli b/parsing/egramml.mli
index f71c368a..1ad94720 100644
--- a/parsing/egramml.mli
+++ b/parsing/egramml.mli
@@ -6,24 +6,26 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Vernacexpr
+
 (** 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 =
+type 's grammar_prod_item =
   | GramTerminal of string
-  | GramNonTerminal of Loc.t * Genarg.argument_type *
-      Pcoq.prod_entry_key * Names.Id.t option
+  | GramNonTerminal : Loc.t * 'a Genarg.raw_abstract_argument_type *
+      ('s, 'a) Extend.symbol -> 's grammar_prod_item
 
 val extend_vernac_command_grammar :
-  Vernacexpr.extend_name -> Vernacexpr.vernac_expr Pcoq.Gram.entry option ->
-    grammar_prod_item list -> unit
+  Vernacexpr.extend_name -> vernac_expr Pcoq.Gram.entry option ->
+    vernac_expr grammar_prod_item list -> unit
 
-val get_extend_vernac_rule : Vernacexpr.extend_name -> grammar_prod_item list
+val get_extend_vernac_rule : Vernacexpr.extend_name -> vernac_expr 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
+  (Loc.t -> Genarg.raw_generic_argument list -> 'a) ->
+  'a grammar_prod_item list -> 'a Extend.production_rule
diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4
index 5edb7b80..7f3a3d10 100644
--- a/parsing/g_constr.ml4
+++ b/parsing/g_constr.ml4
@@ -29,7 +29,7 @@ let constr_kw =
     "Prop"; "Set"; "Type"; ".("; "_"; "..";
     "`{"; "`("; "{|"; "|}" ]
 
-let _ = List.iter Lexer.add_keyword constr_kw
+let _ = List.iter CLexer.add_keyword constr_kw
 
 let mk_cast = function
     (c,(_,None)) -> c
@@ -55,7 +55,7 @@ let mk_fixb (id,bl,ann,body,(loc,tyc)) =
 
 let mk_cofixb (id,bl,ann,body,(loc,tyc)) =
   let _ = Option.map (fun (aloc,_) ->
-    Errors.user_err_loc
+    CErrors.user_err_loc
       (aloc,"Constr:mk_cofixb",
        Pp.str"Annotation forbidden in cofix expression.")) (fst ann) in
   let ty = match tyc with
@@ -127,15 +127,12 @@ let name_colon =
 let aliasvar = function CPatAlias (loc, _, id) -> Some (loc,Name id) | _ -> None
 
 GEXTEND Gram
-  GLOBAL: binder_constr lconstr constr operconstr sort global
+  GLOBAL: binder_constr lconstr constr operconstr universe_level sort global
   constr_pattern lconstr_pattern Constr.ident
   closed_binder open_binders binder binders binders_fixannot
   record_declaration typeclass_constraint pattern appl_arg;
   Constr.ident:
-    [ [ id = Prim.ident -> id
-
-      (* This is used in quotations and Syntax *)
-      | id = METAIDENT -> Id.of_string id ] ]
+    [ [ id = Prim.ident -> id ] ]
   ;
   Prim.name:
     [ [ "_" -> (!@loc, Anonymous) ] ]
@@ -218,16 +215,13 @@ GEXTEND Gram
 	  CGeneralization (!@loc, Implicit, None, c)
       | "`("; c = operconstr LEVEL "200"; ")" ->
 	  CGeneralization (!@loc, Explicit, None, c)
-      | "ltac:"; "("; tac = Tactic.tactic_expr; ")" ->
+      | IDENT "ltac"; ":"; "("; tac = Tactic.tactic_expr; ")" ->
           let arg = Genarg.in_gen (Genarg.rawwit Constrarg.wit_tactic) tac in
           CHole (!@loc, None, IntroAnonymous, Some arg)
       ] ]
   ;
   record_declaration:
-    [ [ fs = record_fields -> CRecord (!@loc, None, fs)
-(*       | c = lconstr; "with"; fs = LIST1 record_field_declaration SEP ";" -> *)
-(* 	  CRecord (!@loc, Some c, fs) *)
-    ] ]
+    [ [ fs = record_fields -> CRecord (!@loc, fs) ] ]
   ;
 
   record_fields:
@@ -267,14 +261,14 @@ GEXTEND Gram
           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)])
+	    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" ->
@@ -304,10 +298,10 @@ GEXTEND Gram
       | -> [] ] ]
   ;
   instance:
-    [ [ "@{"; l = LIST1 level; "}" -> Some l
+    [ [ "@{"; l = LIST1 universe_level; "}" -> Some l
       | -> None ] ]
   ;
-  level:
+  universe_level:
     [ [ "Set" -> GSet
       | "Prop" -> GProp
       | "Type" -> GType None
@@ -338,11 +332,10 @@ GEXTEND Gram
         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=pattern -> t] -> (ona,ty) ] ]
+    [ [ c=operconstr LEVEL "100";
+        ona = OPT ["as"; id=name -> id];
+	ty = OPT ["in"; t=pattern -> t] ->
+	   (c,ona,ty) ] ]
   ;
   case_type:
     [ [ "return"; ty = operconstr LEVEL "100" -> ty ] ]
@@ -386,14 +379,17 @@ GEXTEND Gram
     | "10" RIGHTA
       [ p = pattern; lp = LIST1 NEXT ->
         (match p with
-	  | CPatAtom (_, Some r) -> CPatCstr (!@loc, r, [], lp)
+	  | CPatAtom (_, Some r) -> CPatCstr (!@loc, r, None, lp)
+	  | CPatCstr (_, r, None, l2) -> CErrors.user_err_loc
+              (cases_pattern_expr_loc p, "compound_pattern",
+               Pp.str "Nested applications not supported.")
 	  | CPatCstr (_, r, l1, l2) -> CPatCstr (!@loc, r, l1 , l2@lp)
 	  | CPatNotation (_, n, s, l) -> CPatNotation (!@loc, n , s, l@lp)
-          | _ -> Errors.user_err_loc
+          | _ -> CErrors.user_err_loc
               (cases_pattern_expr_loc p, "compound_pattern",
                Pp.str "Such pattern cannot have arguments."))
-      |"@"; r = Prim.reference; lp = LIST1 NEXT ->
-        CPatCstr (!@loc, r, lp, []) ]
+      |"@"; r = Prim.reference; lp = LIST0 NEXT ->
+        CPatCstr (!@loc, r, Some lp, []) ]
     | "1" LEFTA
       [ c = pattern; "%"; key=IDENT -> CPatDelimiters (!@loc,key,c) ]
     | "0"
@@ -405,6 +401,14 @@ GEXTEND Gram
               CPatPrim (_,Numeral z) when Bigint.is_pos_or_zero z ->
                 CPatNotation(!@loc,"( _ )",([p],[]),[])
             | _ -> p)
+      | "("; p = pattern LEVEL "200"; ":"; ty = lconstr; ")" ->
+          let p =
+            match p with
+              CPatPrim (_,Numeral z) when Bigint.is_pos_or_zero z ->
+                CPatNotation(!@loc,"( _ )",([p],[]),[])
+            | _ -> p
+          in
+	  CPatCast (!@loc, p, ty)
       | n = INT -> CPatPrim (!@loc, Numeral (Bigint.of_string n))
       | s = string -> CPatPrim (!@loc, String s) ] ]
   ;
@@ -480,6 +484,13 @@ GEXTEND Gram
 	  List.map (fun (n, b, t) -> LocalRawAssum ([n], Generalized (Implicit, Explicit, b), t)) tc
       | "`{"; tc = LIST1 typeclass_constraint SEP "," ; "}" ->
 	  List.map (fun (n, b, t) -> LocalRawAssum ([n], Generalized (Implicit, Implicit, b), t)) tc
+      | "'"; p = pattern LEVEL "0" ->
+          let (p, ty) =
+            match p with
+            | CPatCast (_, p, ty) -> (p, Some ty)
+            | _ -> (p, None)
+          in
+          [LocalPattern (!@loc, p, ty)]
     ] ]
   ;
   typeclass_constraint:
diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4
index 5297c163..b90e06cd 100644
--- a/parsing/g_prim.ml4
+++ b/parsing/g_prim.ml4
@@ -15,7 +15,7 @@ open Pcoq
 open Pcoq.Prim
 
 let prim_kw = ["{"; "}"; "["; "]"; "("; ")"; "'"]
-let _ = List.iter Lexer.add_keyword prim_kw
+let _ = List.iter CLexer.add_keyword prim_kw
 
 
 let local_make_qualid l id = make_qualid (DirPath.make l) id
@@ -28,7 +28,7 @@ let my_int_of_string loc s =
     if n > 1024 * 2048 then raise Exit;
     n
   with Failure _ | Exit ->
-    Errors.user_err_loc (loc,"",Pp.str "Cannot support a so large number.")
+    CErrors.user_err_loc (loc,"",Pp.str "Cannot support a so large number.")
 
 GEXTEND Gram
   GLOBAL:
@@ -93,7 +93,7 @@ GEXTEND Gram
   ;
   ne_string:
     [ [ s = STRING ->
-        if s="" then Errors.user_err_loc(!@loc, "", Pp.str"Empty string."); s
+        if s="" then CErrors.user_err_loc(!@loc, "", Pp.str"Empty string."); s
     ] ]
   ;
   ne_lstring:
diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4
index 422384f3..70c5d5d8 100644
--- a/parsing/g_proofs.ml4
+++ b/parsing/g_proofs.ml4
@@ -88,7 +88,7 @@ GEXTEND Gram
       | IDENT "Show"; IDENT "Proof" -> VernacShow ShowProof
       | IDENT "Show"; IDENT "Intro" -> VernacShow (ShowIntros false)
       | IDENT "Show"; IDENT "Intros" -> VernacShow (ShowIntros true)
-      | IDENT "Show"; IDENT "Match"; id = identref -> VernacShow (ShowMatch id)
+      | IDENT "Show"; IDENT "Match"; id = reference -> VernacShow (ShowMatch id)
       | IDENT "Show"; IDENT "Thesis" -> VernacShow ShowThesis
       | IDENT "Guarded" -> VernacCheckGuard
       (* Hints for Auto and EAuto *)
@@ -103,10 +103,9 @@ GEXTEND Gram
       (* Declare "Resolve" explicitly so as to be able to later extend with
          "Resolve ->" and "Resolve <-" *)
       | IDENT "Hint"; IDENT "Resolve"; lc = LIST1 reference_or_constr; 
-	  pri = OPT [ "|"; i = natural -> i ];
-	  dbnames = opt_hintbases ->
+	info = hint_info; dbnames = opt_hintbases ->
 	  VernacHints (false,dbnames,
-	    HintsResolve (List.map (fun x -> (pri, true, x)) lc))
+	    HintsResolve (List.map (fun x -> (info, true, x)) lc))
       ] ];
   obsolete_locality:
     [ [ IDENT "Local" -> true | -> false ] ]
@@ -116,9 +115,8 @@ GEXTEND Gram
      | c = constr -> HintsConstr c ] ]
   ;
   hint:
-    [ [ IDENT "Resolve"; lc = LIST1 reference_or_constr; 
-	pri = OPT [ "|"; i = natural -> i ] ->
-          HintsResolve (List.map (fun x -> (pri, true, x)) lc)
+    [ [ IDENT "Resolve"; lc = LIST1 reference_or_constr; info = hint_info ->
+          HintsResolve (List.map (fun x -> (info, 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)
@@ -134,6 +132,8 @@ GEXTEND Gram
       | ":"; t = lconstr; ":="; c = lconstr -> CCast(!@loc,c,CastConv t) ] ]
   ;
   mode:
-    [ [ l = LIST1 ["+" -> true | "-" -> false] -> l ] ]
+    [ [ l = LIST1 [ "+" -> ModeInput
+                  | "!" -> ModeNoHeadEvar
+                  | "-" -> ModeOutput ] -> l ] ]
   ;
 END
diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4
index 2a00a176..3152afb2 100644
--- a/parsing/g_tactic.ml4
+++ b/parsing/g_tactic.ml4
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Tacexpr
 open Genredexpr
@@ -22,10 +22,10 @@ open Decl_kinds
 open Pcoq
 
 
-let all_with delta = Redops.make_red_flag [FBeta;FIota;FZeta;delta]
+let all_with delta = Redops.make_red_flag [FBeta;FMatch;FFix;FCofix;FZeta;delta]
 
 let tactic_kw = [ "->"; "<-" ; "by" ]
-let _ = List.iter Lexer.add_keyword tactic_kw
+let _ = List.iter CLexer.add_keyword tactic_kw
 
 let err () = raise Stream.Failure
 
@@ -111,8 +111,8 @@ let check_for_coloneq =
       | KEYWORD "(" -> skip_binders 2
       | _ -> err ())
 
-let lookup_at_as_coma =
-  Gram.Entry.of_parser "lookup_at_as_coma"
+let lookup_at_as_comma =
+  Gram.Entry.of_parser "lookup_at_as_comma"
     (fun strm ->
       match get_tok (stream_nth 0 strm) with
 	| KEYWORD (","|"at"|"as") -> ()
@@ -141,11 +141,11 @@ let mk_cofix_tac (loc,id,bl,ann,ty) =
   (id,CProdN(loc,bl,ty))
 
 (* Functions overloaded by quotifier *)
-let induction_arg_of_constr (c,lbind as clbind) = match lbind with
+let destruction_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
+      with e when CErrors.noncritical e -> ElimOnConstr clbind
     end
   | _ -> ElimOnConstr clbind
 
@@ -211,12 +211,16 @@ let merge_occurrences loc cl = function
     in
     (Some p, ans)
 
+let warn_deprecated_eqn_syntax =
+  CWarnings.create ~name:"deprecated-eqn-syntax" ~category:"deprecated"
+         (fun arg -> strbrk (Printf.sprintf "Syntax \"_eqn:%s\" is deprecated. Please use \"eqn:%s\" instead." arg arg))
+
 (* Auxiliary grammar rules *)
 
 GEXTEND Gram
   GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis
   bindings red_expr int_or_var open_constr uconstr
-  simple_intropattern clause_dft_concl hypident;
+  simple_intropattern in_clause clause_dft_concl hypident destruction_arg;
 
   int_or_var:
     [ [ n = integer  -> ArgArg n
@@ -231,16 +235,16 @@ GEXTEND Gram
     [ [ id = identref -> id ] ]
   ;
   open_constr:
-    [ [ c = constr -> ((),c) ] ]
+    [ [ c = constr -> c ] ]
   ;
   uconstr:
     [ [ c = constr -> c ] ]
   ;
-  induction_arg:
+  destruction_arg:
     [ [ n = natural -> (None,ElimOnAnonHyp n)
       | test_lpar_id_rpar; c = constr_with_bindings ->
-        (Some false,induction_arg_of_constr c)
-      | c = constr_with_bindings -> (None,induction_arg_of_constr c)
+        (Some false,destruction_arg_of_constr c)
+      | c = constr_with_bindings_arg -> on_snd destruction_arg_of_constr c
     ] ]
   ;
   constr_with_bindings_arg:
@@ -281,19 +285,23 @@ GEXTEND Gram
   intropatterns:
     [ [ l = LIST0 nonsimple_intropattern -> l ]]
   ;
+  ne_intropatterns:
+    [ [ l = LIST1 nonsimple_intropattern -> l ]]
+  ;
   or_and_intropattern:
-    [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> tc
-      | "()" -> [[]]
-      | "("; si = simple_intropattern; ")" -> [[si]]
+    [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> IntroOrPattern tc
+      | "()" -> IntroAndPattern []
+      | "("; si = simple_intropattern; ")" -> IntroAndPattern [si]
       | "("; si = simple_intropattern; ",";
-             tc = LIST1 simple_intropattern SEP "," ; ")" -> [si::tc]
+             tc = LIST1 simple_intropattern SEP "," ; ")" ->
+             IntroAndPattern (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 -> [l]
-	    | t::q -> [[t;(loc_of_ne_list q,IntroAction (IntroOrAndPattern (pairify q)))]]
-	  in pairify (si::tc) ] ]
+	    | ([]|[_]|[_;_]) as l -> l
+	    | t::q -> [t;(loc_of_ne_list q,IntroAction (IntroOrAndPattern (IntroAndPattern (pairify q))))]
+	  in IntroAndPattern (pairify (si::tc)) ] ]
   ;
   equality_intropattern:
     [ [ "->" -> IntroRewrite true
@@ -334,20 +342,20 @@ GEXTEND Gram
           ExplicitBindings bl
       | bl = LIST1 constr -> ImplicitBindings bl ] ]
   ;
-  opt_bindings:
-    [ [ bl = LIST1 bindings SEP "," -> bl | -> [NoBindings] ] ]
-  ;
   constr_with_bindings:
     [ [ c = constr; l = with_bindings -> (c, l) ] ]
   ;
   with_bindings:
     [ [ "with"; bl = bindings -> bl | -> NoBindings ] ]
   ;
-  red_flag:
-    [ [ IDENT "beta" -> FBeta
-      | IDENT "iota" -> FIota
-      | IDENT "zeta" -> FZeta
-      | IDENT "delta"; d = delta_flag -> d
+  red_flags:
+    [ [ IDENT "beta" -> [FBeta]
+      | IDENT "iota" -> [FMatch;FFix;FCofix]
+      | IDENT "match" -> [FMatch]
+      | IDENT "fix" -> [FFix]
+      | IDENT "cofix" -> [FCofix]
+      | IDENT "zeta" -> [FZeta]
+      | IDENT "delta"; d = delta_flag -> [d]
     ] ]
   ;
   delta_flag:
@@ -357,7 +365,7 @@ GEXTEND Gram
     ] ]
   ;
   strategy_flag:
-    [ [ s = LIST1 red_flag -> Redops.make_red_flag s
+    [ [ s = LIST1 red_flags -> Redops.make_red_flag (List.flatten s)
       | d = delta_flag -> all_with d
     ] ]
   ;
@@ -450,15 +458,6 @@ GEXTEND Gram
     [ [ check_for_coloneq; "(";  id = ident; bl = LIST0 simple_binder;
         ":="; c = lconstr; ")" -> (id, mkCLambdaN_simple bl c) ] ]
   ;
-  hintbases:
-    [ [ "with"; "*" -> None
-      | "with"; l = LIST1 [ x = IDENT -> x] -> Some l
-      | -> Some [] ] ]
-  ;
-  auto_using:
-    [ [ "using"; l = LIST1 constr SEP "," -> l
-      | -> [] ] ]
-  ;
   eliminator:
     [ [ "using"; el = constr_with_bindings -> el ] ]
   ;
@@ -477,42 +476,35 @@ GEXTEND Gram
   eqn_ipat:
     [ [ 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 (!@loc, pat)
+         let loc = !@loc in
+	 warn_deprecated_eqn_syntax ~loc "H"; Some (loc, pat)
       | IDENT "_eqn" ->
-        let msg = "Obsolete syntax \"_eqn\" could be replaced by \"eqn:?\"" in
-        msg_warning (strbrk msg); Some (!@loc, IntroAnonymous)
+         let loc = !@loc in
+	 warn_deprecated_eqn_syntax ~loc "?"; Some (loc, IntroAnonymous)
       | -> None ] ]
   ;
   as_name:
     [ [ "as"; id = ident -> Names.Name id | -> Names.Anonymous ] ]
   ;
   by_tactic:
-    [ [ "by"; tac = tactic_expr LEVEL "3" -> TacComplete tac
-      | -> TacId [] ] ]
-  ;
-  opt_by_tactic:
     [ [ "by"; tac = tactic_expr LEVEL "3" -> Some tac
     | -> None ] ]
   ;
-  rename :
-    [ [ id1 = id_or_meta; IDENT "into"; id2 = id_or_meta -> (id1,id2) ] ]
-  ;
   rewriter :
-    [ [ "!"; c = constr_with_bindings -> (RepeatPlus,(None,c))
+    [ [ "!"; c = constr_with_bindings_arg -> (RepeatPlus,c)
       | ["?"| LEFTQMARK]; c = constr_with_bindings_arg -> (RepeatStar,c)
-      | n = natural; "!"; c = constr_with_bindings -> (Precisely n,(None,c))
+      | n = natural; "!"; c = constr_with_bindings_arg -> (Precisely n,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))
+      | c = constr_with_bindings_arg -> (Precisely 1, c)
       ] ]
   ;
   oriented_rewriter :
     [ [ b = orient; p = rewriter -> let (m,c) = p in (b,m,c) ] ]
   ;
   induction_clause:
-    [ [ c = induction_arg; pat = as_or_and_ipat; eq = eqn_ipat; cl = opt_clause
-        -> (c,(eq,pat),cl) ] ]
+    [ [ c = destruction_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;
@@ -523,23 +515,15 @@ GEXTEND Gram
         | _,_,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 "top" -> MoveFirst
-      | "at"; IDENT "bottom" -> MoveLast ] ]
-  ;
   simple_tactic:
     [ [
       (* Basic tactics *)
-        IDENT "intros"; pl = intropatterns -> TacAtom (!@loc, TacIntroPattern pl)
-      | IDENT "intro"; id = ident; hto = move_location ->
-	  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 "intros"; pl = ne_intropatterns ->
+          TacAtom (!@loc, TacIntroPattern (false,pl))
+      | IDENT "intros" ->
+          TacAtom (!@loc, TacIntroPattern (false,[!@loc,IntroForthcoming false]))
+      | IDENT "eintros"; pl = ne_intropatterns ->
+          TacAtom (!@loc, TacIntroPattern (true,pl))
 
       | IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ",";
           inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,false,cl,inhyp))
@@ -557,12 +541,8 @@ GEXTEND Gram
           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 ->
 	  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 ->
 	  TacAtom (!@loc, TacMutualCofix (id,List.map mk_cofix_tac fd))
 
@@ -605,60 +585,26 @@ GEXTEND Gram
       | IDENT "generalize"; c = constr; l = LIST1 constr ->
 	  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;
+      | IDENT "generalize"; c = constr; lookup_at_as_comma; nl = occs;
           na = as_name;
           l = LIST0 [","; c = pattern_occ; na = as_name -> (c,na)] ->
           TacAtom (!@loc, TacGeneralize (((nl,c),na)::l))
-      | IDENT "generalize"; IDENT "dependent"; c = constr -> TacAtom (!@loc, TacGeneralizeDep c)
 
       (* Derived basic tactics *)
       | IDENT "induction"; ic = induction_clause_list ->
 	  TacAtom (!@loc, TacInductionDestruct (true,false,ic))
       | IDENT "einduction"; ic = induction_clause_list ->
 	  TacAtom (!@loc, TacInductionDestruct(true,true,ic))
-      | IDENT "double"; IDENT "induction"; h1 = quantified_hypothesis;
-	  h2 = quantified_hypothesis -> TacAtom (!@loc, TacDoubleInduction (h1,h2))
       | IDENT "destruct"; icl = induction_clause_list ->
 	  TacAtom (!@loc, TacInductionDestruct(false,false,icl))
       | IDENT "edestruct";  icl = induction_clause_list ->
 	  TacAtom (!@loc, TacInductionDestruct(false,true,icl))
 
-      (* Automation tactic *)
-      | IDENT "trivial"; lems = auto_using; db = hintbases ->
-          TacAtom (!@loc, TacTrivial (Off, lems, db))
-      | IDENT "info_trivial"; lems = auto_using; db = hintbases ->
-          TacAtom (!@loc, TacTrivial (Info, lems, db))
-      | IDENT "debug"; IDENT "trivial"; lems = auto_using; db = hintbases ->
-          TacAtom (!@loc, TacTrivial (Debug, lems, db))
-      | IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases ->
-          TacAtom (!@loc, TacAuto (Off, n, lems, db))
-      | IDENT "info_auto"; n = OPT int_or_var; lems = auto_using; db = hintbases ->
-          TacAtom (!@loc, TacAuto (Info, n, lems, db))
-      | IDENT "debug"; IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases ->
-          TacAtom (!@loc, TacAuto (Debug, n, lems, db))
-
-      (* Context management *)
-      | 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 ->
-	  TacAtom (!@loc, TacMove (hfrom,hto))
-      | IDENT "rename"; l = LIST1 rename SEP "," -> TacAtom (!@loc, TacRename l)
-
-      (* Constructors *)
-      | "exists"; bll = opt_bindings -> TacAtom (!@loc, TacSplit (false,bll))
-      | IDENT "eexists"; bll = opt_bindings ->
-	  TacAtom (!@loc, TacSplit (true,bll))
-      (* Equivalence relations *)
-      | 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 -> TacAtom (!@loc, TacRewrite (false,l,cl,t))
+	  cl = clause_dft_concl; t=by_tactic -> TacAtom (!@loc, TacRewrite (false,l,cl,t))
       | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ",";
-	  cl = clause_dft_concl; t=opt_by_tactic -> TacAtom (!@loc, TacRewrite (true,l,cl,t))
+	  cl = clause_dft_concl; t=by_tactic -> TacAtom (!@loc, TacRewrite (true,l,cl,t))
       | IDENT "dependent"; k =
 	  [ IDENT "simple"; IDENT "inversion" -> SimpleInversion
 	  | IDENT "inversion" -> FullInversion
diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4
index 839f768b..e61be53a 100644
--- a/parsing/g_vernac.ml4
+++ b/parsing/g_vernac.ml4
@@ -8,7 +8,7 @@
 
 open Pp
 open Compat
-open Errors
+open CErrors
 open Util
 open Names
 open Constrexpr
@@ -20,22 +20,19 @@ open Misctypes
 open Tok (* necessary for camlp4 *)
 
 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
+let _ = List.iter CLexer.add_keyword vernac_kw
 
 (* Rem: do not join the different GEXTEND into one, it breaks native *)
 (* compilation on PowerPC and Sun architectures *)
 
 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"
 let subprf = Gram.entry_create "vernac:subprf"
 
 let class_rawexpr = Gram.entry_create "vernac:class_rawexpr"
@@ -48,21 +45,6 @@ let subgoal_command = Gram.entry_create "proof_mode:subgoal_command"
 let instance_name = Gram.entry_create "vernac:instance_name"
 let section_subset_expr = Gram.entry_create "vernac:section_subset_expr"
 
-let command_entry = ref noedit_mode
-let set_command_entry e = command_entry := e
-let get_command_entry () = !command_entry
-
-
-(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for
-    proof editing and changes nothing else). Then sets it as the default proof mode. *)
-let set_tactic_mode () = set_command_entry tactic_mode
-let set_noedit_mode () = set_command_entry noedit_mode
-let _ = Proof_global.register_proof_mode {Proof_global.
-					    name = "Classic" ;
-					    set = set_tactic_mode ;
-					    reset = set_noedit_mode
-					 }
-
 let make_bullet s =
   let n = String.length s in
   match s.[0] with
@@ -71,26 +53,11 @@ let make_bullet s =
   | '*' -> Star n
   | _ -> assert false
 
-(* Hack to parse "[ id" without dropping [ *)
-let test_bracket_ident =
-  Gram.Entry.of_parser "test_bracket_ident"
-    (fun strm ->
-      match get_tok (stream_nth 0 strm) with
-        | KEYWORD "[" ->
-            (match get_tok (stream_nth 1 strm) with
-              | IDENT _ -> ()
-	      | _ -> raise Stream.Failure)
-	| _ -> raise Stream.Failure)
-
-let default_command_entry =
-  Gram.Entry.of_parser "command_entry"
-    (fun strm -> Gram.parse_tokens_after_filter (get_command_entry ()) strm)
-
 GEXTEND Gram
-  GLOBAL: vernac gallina_ext tactic_mode noedit_mode subprf subgoal_command;
+  GLOBAL: vernac gallina_ext noedit_mode subprf subgoal_command;
   vernac: FIRST
-    [ [ IDENT "Time"; l = vernac_list -> VernacTime l
-      | IDENT "Redirect"; s = ne_string; l = vernac_list -> VernacRedirect (s, l)
+    [ [ IDENT "Time"; c = located_vernac -> VernacTime c
+      | IDENT "Redirect"; s = ne_string; c = located_vernac -> VernacRedirect (s, c)
       | IDENT "Timeout"; n = natural; v = vernac -> VernacTimeout(n,v)
       | IDENT "Fail"; v = vernac -> VernacFail v
 
@@ -128,28 +95,13 @@ GEXTEND Gram
       | c = subprf -> c
     ] ]
   ;
-  vernac_list:
-    [ [ c = located_vernac -> [c] ] ]
-  ;
   vernac_aux: LAST
-    [ [ prfcom = default_command_entry -> prfcom ] ]
+    [ [ prfcom = command_entry -> prfcom ] ]
   ;
   noedit_mode:
     [ [ c = subgoal_command -> c None] ]
   ;
 
-  selector:
-    [ [ n=natural; ":" -> SelectNth n
-      | test_bracket_ident; "["; id = ident; "]"; ":" -> SelectId id
-      | IDENT "all" ; ":" -> SelectAll
-      | IDENT "par" ; ":" -> SelectAllParallel ] ]
-  ;
-
-  tactic_mode:
-  [ [ gln = OPT selector;
-      tac = subgoal_command -> tac gln ] ]
-  ;
-
   subprf:
   [ [ s = BULLET -> VernacBullet (make_bullet s)
     | "{" -> VernacSubproof None
@@ -164,35 +116,37 @@ GEXTEND Gram
                     | 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 (Proof_global.get_default_goal_selector ()) g in
-            VernacSolve(g,info,tac,use_dft_tac)) ] ]
+                  end ] ]
   ;
   located_vernac:
     [ [ v = vernac -> !@loc, v ] ]
   ;
 END
 
-let test_plurial_form = function
+let warn_plural_command =
+  CWarnings.create ~name:"plural-command" ~category:"pedantic" ~default:CWarnings.Disabled
+         (fun kwd -> strbrk (Printf.sprintf "Command \"%s\" expects more than one assumption." kwd))
+
+let test_plural_form loc kwd = function
   | [(_,([_],_))] ->
-      Flags.if_verbose msg_warning
-   (strbrk "Keywords Variables/Hypotheses/Parameters expect more than one assumption")
+     warn_plural_command ~loc:!@loc kwd
   | _ -> ()
 
-let test_plurial_form_types = function
+let test_plural_form_types loc kwd = function
   | [([_],_)] ->
-      Flags.if_verbose msg_warning
-   (strbrk "Keywords Implicit Types expect more than one type")
+     warn_plural_command ~loc:!@loc kwd
   | _ -> ()
 
+let fresh_var env c =
+  Namegen.next_ident_away (Id.of_string "pat")
+    (env @ Id.Set.elements (Topconstr.free_vars_of_constr_expr c))
+
+let _ = Hook.set Constrexpr_ops.fresh_var_hook fresh_var
+
 (* Gallina declarations *)
 GEXTEND Gram
   GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion
-    record_field decl_notation rec_definition;
+    record_field decl_notation rec_definition pidentref;
 
   gallina:
       (* Definition, Theorem, Variable, Axiom, ... *)
@@ -203,8 +157,8 @@ GEXTEND Gram
           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;
+      | (kwd,stre) = assumptions_token; nl = inline; bl = assum_list ->
+	  test_plural_form loc kwd bl;
 	  VernacAssumption (stre, nl, bl)
       | d = def_token; id = pidentref; b = def_body ->
           VernacDefinition (d, id, b)
@@ -257,11 +211,11 @@ GEXTEND Gram
       | IDENT "Conjecture" -> (None, Conjectural) ] ]
   ;
   assumptions_token:
-    [ [ IDENT "Hypotheses" -> (Some Discharge, Logical)
-      | IDENT "Variables" -> (Some Discharge, Definitional)
-      | IDENT "Axioms" -> (None, Logical)
-      | IDENT "Parameters" -> (None, Definitional)
-      | IDENT "Conjectures" -> (None, Conjectural) ] ]
+    [ [ IDENT "Hypotheses" -> ("Hypotheses", (Some Discharge, Logical))
+      | IDENT "Variables" -> ("Variables", (Some Discharge, Definitional))
+      | IDENT "Axioms" -> ("Axioms", (None, Logical))
+      | IDENT "Parameters" -> ("Parameters", (None, Definitional))
+      | IDENT "Conjectures" -> ("Conjectures", (None, Conjectural)) ] ]
   ;
   inline:
     [ [ IDENT "Inline"; "("; i = INT; ")" -> InlineAt (int_of_string i)
@@ -272,8 +226,8 @@ GEXTEND Gram
     [ [ i = identref; l = OPT [ "@{" ; l = LIST0 identref; "}" -> l ] -> (i,l) ] ]
   ;
   univ_constraint:
-    [ [ l = identref; ord = [ "<" -> Univ.Lt | "=" -> Univ.Eq | "<=" -> Univ.Le ];
-	r = identref -> (l, ord, r) ] ]
+    [ [ l = universe_level; ord = [ "<" -> Univ.Lt | "=" -> Univ.Eq | "<=" -> Univ.Le ];
+	r = universe_level -> (l, ord, r) ] ]
   ;
   finite_token:
     [ [ "Inductive" -> (Inductive_kw,Finite)
@@ -289,11 +243,19 @@ GEXTEND Gram
   (* Simple definitions *)
   def_body:
     [ [ bl = binders; ":="; red = reduce; c = lconstr ->
+      let (bl, c) = expand_pattern_binders mkCLambdaN bl c in
       (match c with
           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)
+        let ((bl, c), tyo) =
+          if List.exists (function LocalPattern _ -> true | _ -> false) bl
+          then
+            let c = CCast (!@loc, c, CastConv t) in
+            (expand_pattern_binders mkCLambdaN bl c, None)
+          else ((bl, c), Some t)
+        in
+	DefineBody (bl, red, c, tyo)
     | bl = binders; ":"; t = lconstr ->
         ProveBody (bl, t) ] ]
   ;
@@ -462,6 +424,10 @@ let starredidentreflist_to_expr l =
   | [] -> SsEmpty
   | x :: xs -> List.fold_right (fun i acc -> SsUnion(i,acc)) xs x
 
+let warn_deprecated_include_type =
+  CWarnings.create ~name:"deprecated-include-type" ~category:"deprecated"
+         (fun () -> strbrk "Include Type is deprecated; use Include instead")
+
 (* Modules and Sections *)
 GEXTEND Gram
   GLOBAL: gallina_ext module_expr module_type section_subset_expr;
@@ -501,9 +467,8 @@ GEXTEND Gram
       | 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 (strbrk "Include Type is deprecated; use Include instead");
-          VernacInclude(e::l) ] ]
+	 warn_deprecated_include_type ~loc:!@loc ();
+	 VernacInclude(e::l) ] ]
   ;
   export_token:
     [ [ IDENT "Import" -> Some false
@@ -607,9 +572,23 @@ GEXTEND Gram
   ;
 END
 
+let warn_deprecated_arguments_scope =
+  CWarnings.create ~name:"deprecated-arguments-scope" ~category:"deprecated"
+         (fun () -> strbrk "Arguments Scope is deprecated; use Arguments instead")
+
+let warn_deprecated_implicit_arguments =
+  CWarnings.create ~name:"deprecated-implicit-arguments" ~category:"deprecated"
+         (fun () -> strbrk "Implicit Arguments is deprecated; use Arguments instead")
+
+let warn_deprecated_arguments_syntax =
+  CWarnings.create ~name:"deprecated-arguments-syntax" ~category:"deprecated"
+         (fun () -> strbrk "The \"/\" and \"!\" modifiers have an effect only "
+                    ++ strbrk "in the first arguments list. The syntax allowing"
+                    ++ strbrk " them to appear in other lists is deprecated.")
+
 (* Extensions: implicits, coercions, etc. *)
 GEXTEND Gram
-  GLOBAL: gallina_ext instance_name;
+  GLOBAL: gallina_ext instance_name hint_info;
 
   gallina_ext:
     [ [ (* Transparent and Opaque *)
@@ -662,81 +641,69 @@ GEXTEND Gram
 
       | IDENT "Instance"; namesup = instance_name; ":";
 	 expl = [ "!" -> Decl_kinds.Implicit | -> Decl_kinds.Explicit ] ; t = operconstr LEVEL "200";
-	 pri = OPT [ "|"; i = natural -> i ] ;
+	 info = hint_info ;
 	 props = [ ":="; "{"; r = record_declaration; "}" -> Some (true,r) |
 	     ":="; c = lconstr -> Some (false,c) | -> None ] ->
-	   VernacInstance (false,snd namesup,(fst namesup,expl,t),props,pri)
+	   VernacInstance (false,snd namesup,(fst namesup,expl,t),props,info)
 
       | IDENT "Existing"; IDENT "Instance"; id = global;
-          pri = OPT [ "|"; i = natural -> i ] ->
-	  VernacDeclareInstances ([id], pri)
+          info = hint_info ->
+	  VernacDeclareInstances [id, info]
+
       | IDENT "Existing"; IDENT "Instances"; ids = LIST1 global;
-          pri = OPT [ "|"; i = natural -> i ] ->
-	  VernacDeclareInstances (ids, pri)
+        pri = OPT [ "|"; i = natural -> i ] ->
+         let info = { hint_priority = pri; hint_pattern = None } in
+         let insts = List.map (fun i -> (i, info)) ids in
+	  VernacDeclareInstances insts
 
       | IDENT "Existing"; IDENT "Class"; is = global -> VernacDeclareClass is
 
       (* Arguments *)
       | IDENT "Arguments"; qid = smart_global; 
-        impl = LIST1 [ l = LIST0
-        [ item = argument_spec ->
-            let id, r, s = item in [`Id (id,r,s,false,false)]
-        | "/" -> [`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
-            | 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
-            | 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
-            | Some _, Some _ -> error "scope declared twice" in
-            List.map (fun (id,r,s) -> `Id(id,r,f s,true,true)) items
-        ] -> l ] SEP ",";
+        args = LIST0 argument_spec_block;
+        more_implicits = OPT
+          [ ","; impl = LIST1
+            [ impl = LIST0 more_implicits_block ->
+              let warn_deprecated = List.exists fst impl in
+              if warn_deprecated then warn_deprecated_arguments_syntax ~loc:!@loc ();
+              List.flatten (List.map snd impl)]
+            SEP "," -> impl
+          ];
         mods = OPT [ ":"; l = LIST1 arguments_modifier SEP "," -> l ] ->
          let mods = match mods with None -> [] | Some l -> List.flatten l in
-         let impl = List.map List.flatten impl in
-         let rec aux n (narg, impl) = function
-           | `Id x :: tl -> aux (n+1) (narg, impl@[x]) tl
-           | `Slash :: tl -> aux (n+1) (n, impl) tl
-           | [] -> 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 (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 `ReductionNeverUnfold mods then
-           err_incompat "simpl never" "/";
-         if List.mem `ReductionNeverUnfold mods &&
-            List.mem `ReductionDontExposeCase mods then
-           err_incompat "simpl never" "simpl nomatch";
-         VernacArguments (qid, impl, nargs, mods)
-
+         let slash_position = ref None in
+         let rec parse_args i = function
+           | [] -> []
+           | `Id x :: args -> x :: parse_args (i+1) args
+           | `Slash :: args ->
+              if Option.is_empty !slash_position then
+                (slash_position := Some i; parse_args i args)
+              else
+                error "The \"/\" modifier can occur only once"
+         in
+         let args = parse_args 0 (List.flatten args) in
+         let more_implicits = Option.default [] more_implicits in
+         VernacArguments (qid, args, more_implicits, !slash_position, 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 ]; "]" ->
-        msg_warning (strbrk "Arguments Scope is deprecated; use Arguments instead");
+	warn_deprecated_arguments_scope ~loc:!@loc ();
         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 (strbrk "Implicit Arguments is deprecated; use Arguments instead");
-	   VernacDeclareImplicits (qid,pos)
+	 warn_deprecated_implicit_arguments ~loc:!@loc ();
+	 VernacDeclareImplicits (qid,pos)
 
       | IDENT "Implicit"; "Type"; bl = reserv_list ->
 	   VernacReserve bl
 
       | IDENT "Implicit"; IDENT "Types"; bl = reserv_list ->
-          test_plurial_form_types bl;
+          test_plural_form_types loc "Implicit Types" bl;
            VernacReserve bl
 
       | IDENT "Generalizable"; 
@@ -775,6 +742,55 @@ GEXTEND Gram
        snd id, not (Option.is_empty b), Option.map (fun x -> !@loc, x) s
     ]
   ];
+  (* List of arguments implicit status, scope, modifiers *)
+  argument_spec_block: [
+    [ item = argument_spec ->
+      let name, recarg_like, notation_scope = item in
+      [`Id { name=name; recarg_like=recarg_like;
+             notation_scope=notation_scope;
+             implicit_status = NotImplicit}]
+    | "/" -> [`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
+         | Some _, Some _ -> error "scope declared twice" in
+       List.map (fun (name,recarg_like,notation_scope) ->
+           `Id { name=name; recarg_like=recarg_like;
+                 notation_scope=f notation_scope;
+                 implicit_status = NotImplicit}) 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
+         | Some _, Some _ -> error "scope declared twice" in
+       List.map (fun (name,recarg_like,notation_scope) ->
+           `Id { name=name; recarg_like=recarg_like;
+                 notation_scope=f notation_scope;
+                 implicit_status = Implicit}) 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
+         | Some _, Some _ -> error "scope declared twice" in
+       List.map (fun (name,recarg_like,notation_scope) ->
+           `Id { name=name; recarg_like=recarg_like;
+                 notation_scope=f notation_scope;
+                 implicit_status = MaximallyImplicit}) items
+    ]
+  ];
+  name_or_bang: [
+       [ b = OPT "!"; id = name ->
+       not (Option.is_empty b), id
+    ]
+  ];
+  (* Same as [argument_spec_block], but with only implicit status and names *)
+  more_implicits_block: [
+    [ (bang,name) = name_or_bang -> (bang, [(snd name, Vernacexpr.NotImplicit)])
+    | "/" -> (true (* Should warn about deprecated syntax *), [])
+    | "["; items = LIST1 name_or_bang; "]" ->
+       (List.exists fst items, List.map (fun (_,(_,name)) -> (name, Vernacexpr.Implicit)) items)
+    | "{"; items = LIST1 name_or_bang; "}" ->
+       (List.exists fst items, List.map (fun (_,(_,name)) -> (name, Vernacexpr.MaximallyImplicit)) items)
+    ]
+  ];
   strategy_level:
     [ [ IDENT "expand" -> Conv_oracle.Expand
       | IDENT "opaque" -> Conv_oracle.Opaque
@@ -783,10 +799,15 @@ GEXTEND Gram
       | IDENT "transparent" -> Conv_oracle.transparent ] ]
   ;
   instance_name:
-    [ [ name = identref; sup = OPT binders ->
-	  (let (loc,id) = name in (loc, Name id)),
+    [ [ name = pidentref; sup = OPT binders ->
+	  (let ((loc,id),l) = name in ((loc, Name id),l)),
           (Option.default [] sup)
-      | -> (!@loc, Anonymous), []  ] ]
+      | -> ((!@loc, Anonymous), None), []  ] ]
+  ;
+  hint_info:
+    [ [ "|"; i = OPT natural; pat = OPT constr_pattern ->
+         { hint_priority = i; hint_pattern = pat }
+      | -> { hint_priority = None; hint_pattern = None } ] ]
   ;
   reserv_list:
     [ [ bl = LIST1 reserv_tuple -> bl | b = simple_reserv -> [b] ] ]
@@ -804,17 +825,13 @@ GEXTEND Gram
   GLOBAL: command query_command class_rawexpr;
 
   command:
-    [ [ IDENT "Ltac";
-        l = LIST1 tacdef_body SEP "with" ->
-          VernacDeclareTacticDefinition (true, l)
-
-      | IDENT "Comments"; l = LIST0 comment -> VernacComments 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 = [ "!" -> Decl_kinds.Implicit | -> Decl_kinds.Explicit ] ; t = operconstr LEVEL "200";
-	 pri = OPT [ "|"; i = natural -> i ] ->
-	   VernacInstance (true, snd namesup, (fst namesup, expl, t), None, pri)
+	 info = hint_info ->
+	   VernacInstance (true, snd namesup, (fst namesup, expl, t), None, info)
 
       (* System directory *)
       | IDENT "Pwd" -> VernacChdir None
@@ -870,7 +887,20 @@ GEXTEND Gram
 
       (* For acting on parameter tables *)
       | "Set"; table = option_table; v = option_value ->
-  	  VernacSetOption (table,v)
+        begin match v with
+        | StringValue s ->
+          (* We make a special case for warnings because appending is their
+          natural semantics *)
+          if CString.List.equal table ["Warnings"] then
+            VernacSetAppendOption (table, s)
+          else
+            let (last, prefix) = List.sep_last table in
+            if String.equal last "Append" && not (List.is_empty prefix) then
+              VernacSetAppendOption (prefix, s)
+            else
+              VernacSetOption (table, v)
+        | _ -> VernacSetOption (table, v)
+        end
       | "Set"; table = option_table ->
   	  VernacSetOption (table,BoolValue true)
       | IDENT "Unset"; table = option_table ->
@@ -943,7 +973,6 @@ GEXTEND Gram
       | IDENT "Classes" ->  PrintClasses
       | IDENT "TypeClasses" -> PrintTypeClasses
       | IDENT "Instances"; qid = smart_global -> PrintInstances qid
-      | IDENT "Ltac"; qid = global -> PrintLtac qid
       | IDENT "Coercions" -> PrintCoercions
       | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr
          -> PrintCoercionPaths (s,t)
@@ -954,7 +983,6 @@ GEXTEND Gram
       | IDENT "Hint"; qid = smart_global -> PrintHint qid
       | IDENT "Hint"; "*" -> PrintHintDb
       | IDENT "HintDb"; s = IDENT -> PrintHintDbName s
-      | "Rewrite"; IDENT "HintDb"; s = IDENT -> PrintRewriteHintDbName s
       | IDENT "Scopes" -> PrintScopes
       | IDENT "Scope"; s = IDENT -> PrintScope s
       | IDENT "Visibility"; s = OPT [x = IDENT -> x ] -> PrintVisibility s
@@ -1083,7 +1111,7 @@ GEXTEND Gram
 	 VernacDelimiters (sc, None)
 
      | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with";
-       refl = LIST1 smart_global -> VernacBindScope (sc,refl)
+       refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl)
 
      | IDENT "Infix"; local = obsolete_locality;
 	 op = ne_lstring; ":="; p = constr;
@@ -1102,10 +1130,6 @@ GEXTEND Gram
      | 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
-         -> VernacTacticNotation (n,pil,t)
-
      | IDENT "Reserved"; IDENT "Infix"; s = ne_lstring;
 	 l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] ->
 	   Metasyntax.check_infix_modifiers l;
@@ -1131,9 +1155,6 @@ GEXTEND Gram
   obsolete_locality:
     [ [ IDENT "Local" -> true | -> false ] ]
   ;
-  tactic_level:
-    [ [ "("; "at"; IDENT "level"; n = natural; ")" -> n | -> 0 ] ]
-  ;
   level:
     [ [ IDENT "level"; n = natural -> NumLevel n
       | IDENT "next"; IDENT "level" -> NextLevel ] ]
@@ -1143,10 +1164,10 @@ GEXTEND Gram
       | IDENT "left"; IDENT "associativity" -> SetAssoc LeftA
       | IDENT "right"; IDENT "associativity" -> SetAssoc RightA
       | IDENT "no"; IDENT "associativity" -> SetAssoc NonA
-      | IDENT "only"; IDENT "parsing" ->
-        SetOnlyParsing Flags.Current
+      | IDENT "only"; IDENT "printing" -> SetOnlyPrinting
+      | IDENT "only"; IDENT "parsing" -> SetOnlyParsing
       | IDENT "compat"; s = STRING ->
-        SetOnlyParsing (Coqinit.get_compat_version s)
+        SetCompatVersion (Coqinit.get_compat_version s)
       | IDENT "format"; s1 = [s = STRING -> (!@loc,s)];
                         s2 = OPT [s = STRING -> (!@loc,s)] ->
           begin match s1, s2 with
@@ -1165,10 +1186,4 @@ GEXTEND Gram
       | IDENT "closed"; IDENT "binder" -> ETBinder false
     ] ]
   ;
-  production_item:
-    [ [ s = ne_string -> TacTerm s
-      | nt = IDENT;
-        po = OPT [ "("; p = ident; sep = [ -> "" | ","; sep = STRING -> sep ];
-                   ")" -> (p,sep) ] -> TacNonTerm (!@loc,nt,po) ] ]
-  ;
 END
diff --git a/parsing/highparsing.mllib b/parsing/highparsing.mllib
index 13ed8046..8df519b5 100644
--- a/parsing/highparsing.mllib
+++ b/parsing/highparsing.mllib
@@ -3,5 +3,3 @@ G_vernac
 G_prim
 G_proofs
 G_tactic
-G_ltac
-G_obligations
diff --git a/parsing/parsing.mllib b/parsing/parsing.mllib
index a0cb8319..0e1c79c9 100644
--- a/parsing/parsing.mllib
+++ b/parsing/parsing.mllib
@@ -1,6 +1,6 @@
 Tok
 Compat
-Lexer
+CLexer
 Pcoq
 Egramml
 Egramcoq
diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml
new file mode 100644
index 00000000..7dc02190
--- /dev/null
+++ b/parsing/pcoq.ml
@@ -0,0 +1,527 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Pp
+open Compat
+open CErrors
+open Util
+open Extend
+open Genarg
+
+(** The parser of Coq *)
+
+module G = GrammarMake (CLexer)
+
+let warning_verbose = Compat.warning_verbose
+
+let of_coq_assoc = function
+| Extend.RightA -> CompatGramext.RightA
+| Extend.LeftA -> CompatGramext.LeftA
+| Extend.NonA -> CompatGramext.NonA
+
+let of_coq_position = function
+| Extend.First -> CompatGramext.First
+| Extend.Last -> CompatGramext.Last
+| Extend.Before s -> CompatGramext.Before s
+| Extend.After s -> CompatGramext.After s
+| Extend.Level s -> CompatGramext.Level s
+
+module Symbols = GramextMake(G)
+
+let camlp4_verbosity silent f x =
+  let a = !warning_verbose in
+  warning_verbose := silent;
+  f x;
+  warning_verbose := a
+
+let camlp4_verbose f x = camlp4_verbosity (Flags.is_verbose ()) f x
+
+(** Grammar extensions *)
+
+(** NB: [extend_statment =
+         gram_position option * single_extend_statment list]
+    and [single_extend_statment =
+         string option * gram_assoc option * production_rule list]
+    and [production_rule = symbol list * action]
+
+    In [single_extend_statement], first two parameters are name and
+    assoc iff a level is created *)
+
+(** Binding general entry keys to symbol *)
+
+let rec of_coq_action : type a r. (r, a, Loc.t -> r) Extend.rule -> a -> G.action = function
+| Stop -> fun f -> G.action (fun loc -> f (to_coqloc loc))
+| Next (r, _) -> fun f -> G.action (fun x -> of_coq_action r (f x))
+
+let rec symbol_of_prod_entry_key : type s a. (s, a) symbol -> _ = function
+  | Atoken t -> Symbols.stoken t
+  | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s)
+  | Alist1sep (s,sep) ->
+      Symbols.slist1sep (symbol_of_prod_entry_key s, symbol_of_prod_entry_key sep)
+  | Alist0 s -> Symbols.slist0 (symbol_of_prod_entry_key s)
+  | Alist0sep (s,sep) ->
+      Symbols.slist0sep (symbol_of_prod_entry_key s, symbol_of_prod_entry_key sep)
+  | Aopt s -> Symbols.sopt (symbol_of_prod_entry_key s)
+  | Aself -> Symbols.sself
+  | Anext -> Symbols.snext
+  | Aentry e ->
+    Symbols.snterm (G.Entry.obj e)
+  | Aentryl (e, n) ->
+    Symbols.snterml (G.Entry.obj e, string_of_int n)
+  | Arules rs ->
+    G.srules' (List.map symbol_of_rules rs)
+
+and symbol_of_rule : type s a r. (s, a, r) Extend.rule -> _ = function
+| Stop -> fun accu -> accu
+| Next (r, s) -> fun accu -> symbol_of_rule r (symbol_of_prod_entry_key s :: accu)
+
+and symbol_of_rules : type a. a Extend.rules -> _ = function
+| Rules (r, act) ->
+  let symb = symbol_of_rule r.norec_rule [] in
+  let act = of_coq_action r.norec_rule act in
+  (symb, act)
+
+let of_coq_production_rule : type a. a Extend.production_rule -> _ = function
+| Rule (toks, act) -> (symbol_of_rule toks [], of_coq_action toks act)
+
+let of_coq_single_extend_statement (lvl, assoc, rule) =
+  (lvl, Option.map of_coq_assoc assoc, List.map of_coq_production_rule rule)
+
+let of_coq_extend_statement (pos, st) =
+  (Option.map of_coq_position pos, List.map of_coq_single_extend_statement st)
+
+(** Type of reinitialization data *)
+type gram_reinit = gram_assoc * gram_position
+
+type extend_rule =
+| ExtendRule : 'a G.entry * gram_reinit option * 'a extend_statment -> extend_rule
+
+type ext_kind =
+  | ByGrammar of extend_rule
+  | ByEXTEND of (unit -> unit) * (unit -> unit)
+
+(** The list of extensions *)
+
+let camlp4_state = ref []
+
+(** 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);
+  match reinit with
+  | Some (a,ext) ->
+    let a = of_coq_assoc a in
+    let ext = of_coq_position ext in
+    let lev = match pos with
+    | Some (CompatGramext.Level n) -> n
+    | _ -> assert false
+    in
+    maybe_uncurry (G.extend e) (Some ext, [Some lev,Some a,[]])
+  | None -> ()
+
+(** Extension *)
+
+let grammar_extend e reinit ext =
+  let ext = of_coq_extend_statement ext in
+  let undo () = grammar_delete e reinit ext in
+  let redo () = camlp4_verbosity false (maybe_uncurry (G.extend e)) ext in
+  camlp4_state := ByEXTEND (undo, redo) :: !camlp4_state;
+  redo ()
+
+let grammar_extend_sync e reinit ext =
+  camlp4_state := ByGrammar (ExtendRule (e, reinit, ext)) :: !camlp4_state;
+  camlp4_verbosity false (maybe_uncurry (G.extend e)) (of_coq_extend_statement ext)
+
+(** The apparent parser of Coq; encapsulate G to keep track
+    of the extensions. *)
+
+module Gram =
+  struct
+    include G
+    let extend e =
+      maybe_curry
+	(fun ext ->
+	   camlp4_state :=
+	     (ByEXTEND ((fun () -> grammar_delete e None ext),
+			(fun () -> maybe_uncurry (G.extend e) ext)))
+	   :: !camlp4_state;
+	   maybe_uncurry (G.extend e) ext)
+    let delete_rule e pil =
+      (* spiwack: if you use load an ML module which contains GDELETE_RULE
+	  in a section, God kills a kitty. As it would corrupt remove_grammars.
+          There does not seem to be a good way to undo a delete rule. As deleting
+	  takes fewer arguments than extending. The production rule isn't returned
+	  by delete_rule. If we could retrieve the necessary information, then
+	  ByEXTEND provides just the framework we need to allow this in section.
+	  I'm not entirely sure it makes sense, but at least it would be more correct.
+          *)
+      G.delete_rule e pil
+  end
+
+(** Remove extensions
+
+   [n] is the number of extended entries (not the number of Grammar commands!)
+   to remove. *)
+
+let rec remove_grammars n =
+  if n>0 then
+    (match !camlp4_state with
+       | [] -> anomaly ~label:"Pcoq.remove_grammars" (Pp.str "too many rules to remove")
+       | ByGrammar (ExtendRule (g, reinit, ext)) :: t ->
+           grammar_delete g reinit (of_coq_extend_statement ext);
+           camlp4_state := t;
+           remove_grammars (n-1)
+       | ByEXTEND (undo,redo)::t ->
+           undo();
+           camlp4_state := t;
+           remove_grammars n;
+           redo();
+           camlp4_state := ByEXTEND (undo,redo) :: !camlp4_state)
+
+let make_rule r = [None, None, r]
+
+(** An entry that checks we reached the end of the input. *)
+
+let eoi_entry en =
+  let e = Gram.entry_create ((Gram.Entry.name en) ^ "_eoi") in
+  let symbs = [Symbols.snterm (Gram.Entry.obj en); Symbols.stoken Tok.EOI] in
+  let act = Gram.action (fun _ x loc -> x) in
+  maybe_uncurry (Gram.extend e) (None, make_rule [symbs, act]);
+  e
+
+let map_entry f en =
+  let e = Gram.entry_create ((Gram.Entry.name en) ^ "_map") in
+  let symbs = [Symbols.snterm (Gram.Entry.obj en)] in
+  let act = Gram.action (fun x loc -> f x) in
+  maybe_uncurry (Gram.extend e) (None, make_rule [symbs, act]);
+  e
+
+(* Parse a string, does NOT check if the entire string was read
+   (use eoi_entry) *)
+
+let parse_string f x =
+  let strm = Stream.of_string x in Gram.entry_parse f (Gram.parsable strm)
+
+type gram_universe = string
+
+let utables : (string, unit) Hashtbl.t =
+  Hashtbl.create 97
+
+let create_universe u =
+  let () = Hashtbl.add utables u () in
+  u
+
+let uprim   = create_universe "prim"
+let uconstr = create_universe "constr"
+let utactic = create_universe "tactic"
+let uvernac = create_universe "vernac"
+
+let get_univ u =
+  if Hashtbl.mem utables u then u
+  else raise Not_found
+
+let new_entry u s =
+  let ename = u ^ ":" ^ s in
+  let e = Gram.entry_create ename in
+  e
+
+let make_gen_entry u s = new_entry u s
+
+module GrammarObj =
+struct
+  type ('r, _, _) obj = 'r Gram.entry
+  let name = "grammar"
+  let default _ = None
+end
+
+module Grammar = Register(GrammarObj)
+
+let register_grammar = Grammar.register0
+let genarg_grammar = Grammar.obj
+
+let create_generic_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Gram.entry =
+  let e = new_entry u s in
+  let Rawwit t = etyp in
+  let () = Grammar.register0 t e in
+  e
+
+(* Initial grammar entries *)
+
+module Prim =
+  struct
+    let gec_gen n = make_gen_entry uprim n
+
+    (* Entries that can be referred via the string -> Gram.entry table *)
+    (* Typically for tactic or vernac extensions *)
+    let preident = gec_gen "preident"
+    let ident = gec_gen "ident"
+    let natural = gec_gen "natural"
+    let integer = gec_gen "integer"
+    let bigint = Gram.entry_create "Prim.bigint"
+    let string = gec_gen "string"
+    let reference = make_gen_entry uprim "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 "var"
+
+    let name = Gram.entry_create "Prim.name"
+    let identref = Gram.entry_create "Prim.identref"
+    let pidentref = Gram.entry_create "Prim.pidentref"
+    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 *)
+    let base_ident = Gram.entry_create "Prim.base_ident"
+
+    let qualid = Gram.entry_create "Prim.qualid"
+    let fullyqualid = Gram.entry_create "Prim.fullyqualid"
+    let dirpath = Gram.entry_create "Prim.dirpath"
+
+    let ne_string = Gram.entry_create "Prim.ne_string"
+    let ne_lstring = Gram.entry_create "Prim.ne_lstring"
+
+  end
+
+module Constr =
+  struct
+    let gec_constr = make_gen_entry uconstr
+
+    (* Entries that can be referred via the string -> Gram.entry table *)
+    let constr = gec_constr "constr"
+    let operconstr = gec_constr "operconstr"
+    let constr_eoi = eoi_entry constr
+    let lconstr = gec_constr "lconstr"
+    let binder_constr = gec_constr "binder_constr"
+    let ident = make_gen_entry uconstr "ident"
+    let global = make_gen_entry uconstr "global"
+    let universe_level = make_gen_entry uconstr "universe_level"
+    let sort = make_gen_entry uconstr "sort"
+    let pattern = Gram.entry_create "constr:pattern"
+    let constr_pattern = gec_constr "constr_pattern"
+    let lconstr_pattern = gec_constr "lconstr_pattern"
+    let closed_binder = Gram.entry_create "constr:closed_binder"
+    let binder = Gram.entry_create "constr:binder"
+    let binders = Gram.entry_create "constr:binders"
+    let open_binders = Gram.entry_create "constr:open_binders"
+    let binders_fixannot = Gram.entry_create "constr:binders_fixannot"
+    let typeclass_constraint = Gram.entry_create "constr:typeclass_constraint"
+    let record_declaration = Gram.entry_create "constr:record_declaration"
+    let appl_arg = Gram.entry_create "constr:appl_arg"
+  end
+
+module Module =
+  struct
+    let module_expr = Gram.entry_create "module_expr"
+    let module_type = Gram.entry_create "module_type"
+  end
+
+module Tactic =
+  struct
+    (* Main entry for extensions *)
+    let simple_tactic = Gram.entry_create "tactic:simple_tactic"
+
+    (* Entries that can be referred via the string -> Gram.entry table *)
+    (* Typically for tactic user extensions *)
+    let open_constr =
+      make_gen_entry utactic "open_constr"
+    let constr_with_bindings =
+      make_gen_entry utactic "constr_with_bindings"
+    let bindings =
+      make_gen_entry utactic "bindings"
+    let hypident = Gram.entry_create "hypident"
+    let constr_may_eval = make_gen_entry utactic "constr_may_eval"
+    let constr_eval = make_gen_entry utactic "constr_eval"
+    let uconstr =
+      make_gen_entry utactic "uconstr"
+    let quantified_hypothesis =
+      make_gen_entry utactic "quantified_hypothesis"
+    let destruction_arg = make_gen_entry utactic "destruction_arg"
+    let int_or_var = make_gen_entry utactic "int_or_var"
+    let red_expr = make_gen_entry utactic "red_expr"
+    let simple_intropattern =
+      make_gen_entry utactic "simple_intropattern"
+    let in_clause = make_gen_entry utactic "in_clause"
+    let clause_dft_concl = 
+      make_gen_entry utactic "clause"
+
+
+    (* Main entries for ltac *)
+    let tactic_arg = Gram.entry_create "tactic:tactic_arg"
+    let tactic_expr = make_gen_entry utactic "tactic_expr"
+    let binder_tactic = make_gen_entry utactic "binder_tactic"
+
+    let tactic = make_gen_entry utactic "tactic"
+
+    (* Main entry for quotations *)
+    let tactic_eoi = eoi_entry tactic
+
+  end
+
+module Vernac_ =
+  struct
+    let gec_vernac s = Gram.entry_create ("vernac:" ^ s)
+
+    (* The different kinds of vernacular commands *)
+    let gallina = gec_vernac "gallina"
+    let gallina_ext = gec_vernac "gallina_ext"
+    let command = gec_vernac "command"
+    let syntax = gec_vernac "syntax_command"
+    let vernac = gec_vernac "Vernac.vernac"
+    let vernac_eoi = eoi_entry vernac
+    let rec_definition = gec_vernac "Vernac.rec_definition"
+    let hint_info = gec_vernac "hint_info"
+    (* Main vernac entry *)
+    let main_entry = Gram.entry_create "vernac"
+    let noedit_mode = gec_vernac "noedit_command"
+
+    let () =
+      let act_vernac = Gram.action (fun v loc -> Some (!@loc, v)) in
+      let act_eoi = Gram.action (fun _ loc -> None) in
+      let rule = [
+        ([ Symbols.stoken Tok.EOI ], act_eoi);
+        ([ Symbols.snterm (Gram.Entry.obj vernac) ], act_vernac );
+      ] in
+      maybe_uncurry (Gram.extend main_entry) (None, make_rule rule)
+
+    let command_entry_ref = ref noedit_mode
+    let command_entry =
+      Gram.Entry.of_parser "command_entry"
+        (fun strm -> Gram.parse_tokens_after_filter !command_entry_ref strm)
+
+  end
+
+let main_entry = Vernac_.main_entry
+
+let set_command_entry e = Vernac_.command_entry_ref := e
+let get_command_entry () = !Vernac_.command_entry_ref
+
+let epsilon_value f e =
+  let r = Rule (Next (Stop, e), fun x _ -> f x) in
+  let ext = of_coq_extend_statement (None, [None, None, [r]]) in
+  let entry = G.entry_create "epsilon" in
+  let () = maybe_uncurry (G.extend entry) ext in
+  try Some (parse_string entry "") with _ -> None
+
+(** Synchronized grammar extensions *)
+
+module GramState = Store.Make(struct end)
+
+type 'a grammar_extension = 'a -> GramState.t -> extend_rule list * GramState.t
+
+module GrammarCommand = Dyn.Make(struct end)
+module GrammarInterp = struct type 'a t = 'a grammar_extension end
+module GrammarInterpMap = GrammarCommand.Map(GrammarInterp)
+
+let grammar_interp = ref GrammarInterpMap.empty
+
+let (grammar_stack : (int * GrammarCommand.t * GramState.t) list ref) = ref []
+
+type 'a grammar_command = 'a GrammarCommand.tag
+
+let create_grammar_command name interp : _ grammar_command =
+  let obj = GrammarCommand.create name in
+  let () = grammar_interp := GrammarInterpMap.add obj interp !grammar_interp in
+  obj
+
+let extend_grammar_command tag g =
+  let modify = GrammarInterpMap.find tag !grammar_interp in
+  let grammar_state = match !grammar_stack with
+  | [] -> GramState.empty
+  | (_, _, st) :: _ -> st
+  in
+  let (rules, st) = modify g grammar_state in
+  let iter (ExtendRule (e, reinit, ext)) = grammar_extend_sync e reinit ext in
+  let () = List.iter iter rules in
+  let nb = List.length rules in
+  grammar_stack := (nb, GrammarCommand.Dyn (tag, g), st) :: !grammar_stack
+
+let recover_grammar_command (type a) (tag : a grammar_command) : a list =
+  let filter : _ -> a option = fun (_, GrammarCommand.Dyn (tag', v), _) ->
+    match GrammarCommand.eq tag tag' with
+    | None -> None
+    | Some Refl -> Some v
+  in
+  List.map_filter filter !grammar_stack
+
+let extend_dyn_grammar (GrammarCommand.Dyn (tag, g)) = extend_grammar_command tag g
+
+(* 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 = (int * GrammarCommand.t * GramState.t) list * CLexer.frozen_t
+
+let freeze _ : frozen_t = (!grammar_stack, CLexer.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
+
+let number_of_entries gcl =
+  List.fold_left (fun n (p,_,_) -> n + p) 0 gcl
+
+let unfreeze (grams, lex) =
+  let (undo, redo, common) = factorize_grams !grammar_stack grams in
+  let n = number_of_entries undo in
+  remove_grammars n;
+  grammar_stack := common;
+  CLexer.unfreeze lex;
+  List.iter extend_dyn_grammar (List.rev_map pi2 redo)
+
+(** 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 _ =
+  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 false in
+  try let a = f x in unfreeze fs; a
+  with reraise ->
+    let reraise = CErrors.push reraise in
+    let () = unfreeze fs in
+    iraise reraise
+
+(** Registering grammar of generic arguments *)
+
+let () =
+  let open Stdarg in
+  let open Constrarg in
+(*   Grammar.register0 wit_unit; *)
+(*   Grammar.register0 wit_bool; *)
+  Grammar.register0 wit_int (Prim.integer);
+  Grammar.register0 wit_string (Prim.string);
+  Grammar.register0 wit_pre_ident (Prim.preident);
+  Grammar.register0 wit_int_or_var (Tactic.int_or_var);
+  Grammar.register0 wit_intro_pattern (Tactic.simple_intropattern);
+  Grammar.register0 wit_ident (Prim.ident);
+  Grammar.register0 wit_var (Prim.var);
+  Grammar.register0 wit_ref (Prim.reference);
+  Grammar.register0 wit_quant_hyp (Tactic.quantified_hypothesis);
+  Grammar.register0 wit_constr (Constr.constr);
+  Grammar.register0 wit_uconstr (Tactic.uconstr);
+  Grammar.register0 wit_open_constr (Tactic.open_constr);
+  Grammar.register0 wit_constr_with_bindings (Tactic.constr_with_bindings);
+  Grammar.register0 wit_bindings (Tactic.bindings);
+(*   Grammar.register0 wit_hyp_location_flag; *)
+  Grammar.register0 wit_red_expr (Tactic.red_expr);
+  Grammar.register0 wit_tactic (Tactic.tactic);
+  Grammar.register0 wit_ltac (Tactic.tactic);
+  Grammar.register0 wit_clause_dft_concl (Tactic.clause_dft_concl);
+  Grammar.register0 wit_destruction_arg (Tactic.destruction_arg);
+  ()
diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4
deleted file mode 100644
index 32dbeaa4..00000000
--- a/parsing/pcoq.ml4
+++ /dev/null
@@ -1,836 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \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 Extend
-open Genarg
-open Stdarg
-open Constrarg
-open Tok (* necessary for camlp4 *)
-
-(** The parser of Coq *)
-
-module G = GrammarMake (Lexer)
-
-(* TODO: this is a workaround, since there isn't such
-   [warning_verbose] in new camlp4. In camlp5, this ref
-   gets hidden by [Gramext.warning_verbose] *)
-let warning_verbose = ref true
-
-IFDEF CAMLP5 THEN
-open Gramext
-ELSE
-open PcamlSig.Grammar
-open G
-END
-
-(** Compatibility with Camlp5 6.x *)
-
-IFDEF CAMLP5_6_00 THEN
-let slist0sep x y = Slist0sep (x, y, false)
-let slist1sep x y = Slist1sep (x, y, false)
-ELSE
-let slist0sep x y = Slist0sep (x, y)
-let slist1sep x y = Slist1sep (x, y)
-END
-
-let gram_token_of_token tok =
-IFDEF CAMLP5 THEN
- Stoken (Tok.to_pattern tok)
-ELSE
- match tok with
-  | KEYWORD s -> Skeyword s
-  | tok -> Stoken ((=) tok, to_string tok)
-END
-
-let gram_token_of_string s = gram_token_of_token (Lexer.terminal s)
-
-let camlp4_verbosity silent f x =
-  let a = !warning_verbose in
-  warning_verbose := silent;
-  f x;
-  warning_verbose := a
-
-let camlp4_verbose f x = camlp4_verbosity (Flags.is_verbose ()) f x
-
-
-(** General entry keys *)
-
-(** This intermediate abstract representation of entries can
-   both be reified into mlexpr for the ML extensions and
-   dynamically interpreted as entries for the Coq level extensions
-*)
-
-type prod_entry_key =
-  | Alist1 of prod_entry_key
-  | Alist1sep of prod_entry_key * string
-  | Alist0 of prod_entry_key
-  | Alist0sep of prod_entry_key * string
-  | Aopt of prod_entry_key
-  | Amodifiers of prod_entry_key
-  | Aself
-  | Anext
-  | Atactic of int
-  | Agram of string
-  | Aentry of string * string
-
-(** [grammar_object] is the superclass of all grammar entries *)
-
-module type Gramobj =
-sig
-  type grammar_object
-  val weaken_entry : 'a G.entry -> grammar_object G.entry
-end
-
-module Gramobj : Gramobj =
-struct
-  type grammar_object = Obj.t
-  let weaken_entry e = Obj.magic e
-end
-
-(** Grammar entries with associated types *)
-
-type entry_type = argument_type
-type grammar_object = Gramobj.grammar_object
-type typed_entry = argument_type * grammar_object G.entry
-let in_typed_entry t e = (t,Gramobj.weaken_entry e)
-let type_of_typed_entry (t,e) = t
-let object_of_typed_entry (t,e) = e
-let weaken_entry x = Gramobj.weaken_entry x
-
-module type Gramtypes =
-sig
-  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
-
-module Gramtypes : Gramtypes =
-struct
-  let inGramObj rawwit = in_typed_entry (unquote rawwit)
-  let outGramObj (a:'a raw_abstract_argument_type) o =
-    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
-
-open Gramtypes
-
-(** Grammar extensions *)
-
-(** NB: [extend_statment =
-         gram_position option * single_extend_statment list]
-    and [single_extend_statment =
-         string option * gram_assoc option * production_rule list]
-    and [production_rule = symbol list * action]
-
-    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_reinit option (** for reinitialization if ever needed *)
-      * G.extend_statment
-  | ByEXTEND of (unit -> unit) * (unit -> unit)
-
-(** The list of extensions *)
-
-let camlp4_state = ref []
-
-(** 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);
-  match reinit with
-  | Some (a,ext) ->
-    let lev = match pos with Some (Level n) -> n | _ -> assert false in
-    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. *)
-
-module Gram =
-  struct
-    include G
-    let extend e =
-      maybe_curry
-	(fun ext ->
-	   camlp4_state :=
-	     (ByEXTEND ((fun () -> grammar_delete e None ext),
-			(fun () -> maybe_uncurry (G.extend e) ext)))
-	   :: !camlp4_state;
-	   maybe_uncurry (G.extend e) ext)
-    let delete_rule e pil =
-      (* spiwack: if you use load an ML module which contains GDELETE_RULE
-	  in a section, God kills a kitty. As it would corrupt remove_grammars.
-          There does not seem to be a good way to undo a delete rule. As deleting
-	  takes fewer arguments than extending. The production rule isn't returned
-	  by delete_rule. If we could retrieve the necessary information, then
-	  ByEXTEND provides just the framework we need to allow this in section.
-	  I'm not entirely sure it makes sense, but at least it would be more correct.
-          *)
-      G.delete_rule e pil
-  end
-
-(** This extension command is used by the Grammar constr *)
-
-let grammar_extend e reinit ext =
-  camlp4_state := ByGrammar (weaken_entry e,reinit,ext) :: !camlp4_state;
-  camlp4_verbose (maybe_uncurry (G.extend e)) ext
-
-(** Remove extensions
-
-   [n] is the number of extended entries (not the number of Grammar commands!)
-   to remove. *)
-
-let rec remove_grammars n =
-  if n>0 then
-    (match !camlp4_state with
-       | [] -> anomaly ~label:"Pcoq.remove_grammars" (Pp.str "too many rules to remove")
-       | ByGrammar(g,reinit,ext)::t ->
-           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 ->
-           undo();
-           camlp4_state := t;
-           remove_grammars n;
-           redo();
-           camlp4_state := ByEXTEND (undo,redo) :: !camlp4_state)
-
-(** An entry that checks we reached the end of the input. *)
-
-let eoi_entry en =
-  let e = Gram.entry_create ((Gram.Entry.name en) ^ "_eoi") in
-  GEXTEND Gram
-    e: [ [ x = en; EOI -> x ] ]
-    ;
-  END;
-  e
-
-let map_entry f en =
-  let e = Gram.entry_create ((Gram.Entry.name en) ^ "_map") in
-  GEXTEND Gram
-    e: [ [ x = en -> f x ] ]
-    ;
-  END;
-  e
-
-(* Parse a string, does NOT check if the entire string was read
-   (use eoi_entry) *)
-
-let parse_string f x =
-  let strm = Stream.of_string x in Gram.entry_parse f (Gram.parsable strm)
-
-type gram_universe = string * (string, typed_entry) Hashtbl.t
-
-let trace = ref false
-
-(* The univ_tab is not part of the state. It contains all the grammars that
-   exist or have existed before in the session. *)
-
-let univ_tab = (Hashtbl.create 7 : (string, gram_universe) Hashtbl.t)
-
-let create_univ s =
-  let u = s, Hashtbl.create 29 in Hashtbl.add univ_tab s u; u
-
-let uprim   = create_univ "prim"
-let uconstr = create_univ "constr"
-let utactic = create_univ "tactic"
-let uvernac = create_univ "vernac"
-
-let get_univ s =
-  try
-    Hashtbl.find univ_tab s
-  with Not_found ->
-    anomaly (Pp.str ("Unknown grammar universe: "^s))
-
-let get_entry (u, utab) s = Hashtbl.find utab s
-
-let new_entry etyp (u, utab) s =
-  if !trace then (Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr);
-  let ename = u ^ ":" ^ s in
-  let e = in_typed_entry etyp (Gram.entry_create ename) in
-  Hashtbl.add utab s e; e
-
-let create_entry (u, utab) s etyp =
-  try
-    let e = Hashtbl.find utab s in
-    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 wit_constr) (create_entry uconstr s ConstrArgType)
-
-let create_generic_entry s wit =
-  outGramObj wit (create_entry utactic s (unquote wit))
-
-(* [make_gen_entry] builds entries extensible by giving its name (a string) *)
-(* For entries extensible only via the ML name, Gram.entry_create is enough *)
-
-let make_gen_entry (u,univ) rawwit s =
-  let e = Gram.entry_create (u ^ ":" ^ s) in
-  Hashtbl.add univ s (inGramObj rawwit e); e
-
-(* Initial grammar entries *)
-
-module Prim =
-  struct
-    let gec_gen x = make_gen_entry uprim x
-
-    (* Entries that can be referred via the string -> Gram.entry table *)
-    (* Typically for tactic or vernac extensions *)
-    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 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 wit_var) "var"
-
-    let name = Gram.entry_create "Prim.name"
-    let identref = Gram.entry_create "Prim.identref"
-    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 *)
-    let base_ident = Gram.entry_create "Prim.base_ident"
-
-    let qualid = Gram.entry_create "Prim.qualid"
-    let fullyqualid = Gram.entry_create "Prim.fullyqualid"
-    let dirpath = Gram.entry_create "Prim.dirpath"
-
-    let ne_string = Gram.entry_create "Prim.ne_string"
-    let ne_lstring = Gram.entry_create "Prim.ne_lstring"
-
-  end
-
-module Constr =
-  struct
-    let gec_constr = make_gen_entry uconstr (rawwit wit_constr)
-
-    (* Entries that can be referred via the string -> Gram.entry table *)
-    let constr = gec_constr "constr"
-    let operconstr = gec_constr "operconstr"
-    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 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"
-    let closed_binder = Gram.entry_create "constr:closed_binder"
-    let binder = Gram.entry_create "constr:binder"
-    let binders = Gram.entry_create "constr:binders"
-    let open_binders = Gram.entry_create "constr:open_binders"
-    let binders_fixannot = Gram.entry_create "constr:binders_fixannot"
-    let typeclass_constraint = Gram.entry_create "constr:typeclass_constraint"
-    let record_declaration = Gram.entry_create "constr:record_declaration"
-    let appl_arg = Gram.entry_create "constr:appl_arg"
-  end
-
-module Module =
-  struct
-    let module_expr = Gram.entry_create "module_expr"
-    let module_type = Gram.entry_create "module_type"
-  end
-
-module Tactic =
-  struct
-    (* Main entry for extensions *)
-    let simple_tactic = Gram.entry_create "tactic:simple_tactic"
-
-    (* Entries that can be referred via the string -> Gram.entry table *)
-    (* Typically for tactic user extensions *)
-    let open_constr =
-      make_gen_entry utactic (rawwit wit_open_constr) "open_constr"
-    let constr_with_bindings =
-      make_gen_entry utactic (rawwit wit_constr_with_bindings) "constr_with_bindings"
-    let bindings =
-      make_gen_entry utactic (rawwit wit_bindings) "bindings"
-    let hypident = Gram.entry_create "hypident"
-    let constr_may_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval"
-    let constr_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 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 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 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_ =
-  struct
-    let gec_vernac s = Gram.entry_create ("vernac:" ^ s)
-
-    (* The different kinds of vernacular commands *)
-    let gallina = gec_vernac "gallina"
-    let gallina_ext = gec_vernac "gallina_ext"
-    let command = gec_vernac "command"
-    let syntax = gec_vernac "syntax_command"
-    let vernac = gec_vernac "Vernac.vernac"
-    let vernac_eoi = eoi_entry vernac
-    let rec_definition = gec_vernac "Vernac.rec_definition"
-    (* Main vernac entry *)
-    let main_entry = Gram.entry_create "vernac"
-
-    GEXTEND Gram
-    main_entry:
-      [ [ a = vernac -> Some (!@loc, a) | EOI -> None ] ]
-    ;
-    END
-
-  end
-
-let main_entry = Vernac_.main_entry
-
-(**********************************************************************)
-(* This determines (depending on the associativity of the current
-   level and on the expected associativity) if a reference to constr_n is
-   a reference to the current level (to be translated into "SELF" on the
-   left border and into "constr LEVEL n" elsewhere), to the level below
-   (to be translated into "NEXT") or to an below wrt associativity (to be
-   translated in camlp4 into "constr" without level) or to another level
-   (to be translated into "constr LEVEL n")
-
-   The boolean is true if the entry was existing _and_ empty; this to
-   circumvent a weakness of camlp4/camlp5 whose undo mechanism is not the
-   converse of the extension mechanism *)
-
-let constr_level = string_of_int
-
-let default_levels =
-  [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,Extend.RightA,true;
-   100,Extend.RightA,false;
-   99,Extend.RightA,true;
-   11,Extend.LeftA,false;
-   10,Extend.RightA,false;
-   1,Extend.LeftA,false;
-   0,Extend.RightA,false]
-
-let level_stack =
-  ref [(default_levels, default_pattern_levels)]
-
-(* 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 *)
-
-let admissible_assoc = function
-  | Extend.LeftA, Some (Extend.RightA | Extend.NonA) -> false
-  | Extend.RightA, Some Extend.LeftA -> false
-  | _ -> true
-
-let create_assoc = function
-  | None -> Extend.RightA
-  | Some a -> a
-
-let error_level_assoc p current expected =
-  let pr_assoc = function
-    | 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
-  | None ->
-      level_stack := current :: !level_stack;
-      None, None, None, None
-  | Some n ->
-      let after = ref None in
-      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 Int.equal p n ->
-            if reinit then
-	      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
-	      error_level_assoc p a (Option.get assoc)
-	| l -> after := q; (n,create_assoc assoc,ensure)::l
-      in
-      try
-	let updated =
-	  if forpat then (ccurrent, add_level None pcurrent)
-	  else (add_level None ccurrent, pcurrent) in
-        level_stack := updated:: !level_stack;
-	let assoc = create_assoc assoc in
-        begin match !init with
-        | None ->
-	  (* Create the entry *)
-	   Some (create_pos !after), Some assoc, Some (constr_level n), None
-        | _ ->
-	  (* The reinit flag has been updated *)
-	   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 (Extend.Level (constr_level n)), None, None, None
-
-let remove_levels n =
-  level_stack := List.skipn n !level_stack
-
-let rec list_mem_assoc_triple x = function
-  | [] -> false
-  | (a,b,c) :: l -> Int.equal a x || list_mem_assoc_triple x l
-
-let register_empty_levels forpat 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
-
-(* Synchronise the stack of level updates *)
-let synchronize_level_positions () =
-  let _ = find_position true None None in ()
-
-(**********************************************************************)
-(* Binding constr entry keys to entries                               *)
-
-(* Camlp4 levels do not treat NonA: use RightA with a NEXT on the left *)
-let camlp4_assoc = function
-  | 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
-   the result is
-
-     None = SELF
-     Some None = NEXT
-     Some (Some (n,cur)) = constr LEVEL n
-         s.t. if [cur] is set then [n] is the same as the [from] level *)
-let adjust_level assoc from = function
-(* Associativity is None means force the level *)
-  | (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 (Extend.NonA|Extend.LeftA))) ->
-      Some None
-  (* If RightA on the right-hand side, set to the explicit (current) level *)
-  | (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 Extend.NonA)) -> None
-  (* If the expected assoc is the current one, set to SELF *)
-  | (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)) ->
-    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 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
-  | ETConstr (n,q) ->
-      (if forpat then weaken_entry Constr.pattern
-       else weaken_entry Constr.operconstr),
-      adjust (n,q), false
-  | ETName -> weaken_entry Prim.name, None, false
-  | ETBinder true -> anomaly (Pp.str "Should occur only as part of BinderList")
-  | ETBinder false -> weaken_entry Constr.binder, None, false
-  | ETBinderList (true,tkl) ->
-    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 (Pp.str "List of entries cannot be registered.")
-  | ETOther (u,n) ->
-      let u = get_univ u in
-      let e =
-        try get_entry u n
-        with Not_found when allow_create -> create_entry u n ConstrArgType in
-      object_of_typed_entry e, None, true
-
-(* This computes the name of the level where to add a new rule *)
-let interp_constr_entry_key forpat = function
-  | ETConstr(200,()) when not forpat ->
-      weaken_entry Constr.binder_constr, None
-  | e ->
-      let (e,level,_) = compute_entry true (fun (n,()) -> Some n) forpat e in
-      (e, level)
-
-(* This computes the name to give to a production knowing the name and
-   associativity of the level where it must be added *)
-let interp_constr_prod_entry_key ass from forpat en =
-  compute_entry false (adjust_level ass from) forpat en
-
-(**********************************************************************)
-(* Binding constr entry keys to symbols                               *)
-
-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,_)) -> Int.equal n n'
-    | (ETName,ETName | ETReference, ETReference | ETBigint,ETBigint
-      | ETPattern, ETPattern) -> true
-    | ETOther(s1,s2), ETOther(s1',s2') ->
-      String.equal s1 s1' && String.equal s2 s2'
-    | _ -> false
-
-let is_binder_level from e =
-  match from, e with
-      ETConstr(200,()),
-      ETConstr(NumLevel 200,(BorderProd(Right,_)|InternalProd)) -> true
-    | _ -> false
-
-let make_sep_rules tkl =
-  Gram.srules'
-    [List.map gram_token_of_token tkl,
-     List.fold_right (fun _ v -> Gram.action (fun _ -> v)) tkl
-       (Gram.action (fun loc -> ()))]
-
-let rec symbol_of_constr_prod_entry_key assoc from forpat typ =
-  if is_binder_level from typ then
-    if forpat then
-      Snterml (Gram.Entry.obj Constr.pattern,"200")
-    else
-      Snterml (Gram.Entry.obj Constr.operconstr,"200")
-  else if is_self from typ then
-      Sself
-  else
-    match typ with
-    | ETConstrList (typ',[]) ->
-        Slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'))
-    | ETConstrList (typ',tkl) ->
-        slist1sep
-          (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'))
-          (make_sep_rules tkl)
-    | ETBinderList (false,[]) ->
-        Slist1
-	  (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false))
-    | ETBinderList (false,tkl) ->
-        slist1sep
-          (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false))
-          (make_sep_rules tkl)
-
-    | _ ->
-    match interp_constr_prod_entry_key assoc from forpat typ with
-      | (eobj,None,_) -> Snterm (Gram.Entry.obj eobj)
-      | (eobj,Some None,_) -> Snext
-      | (eobj,Some (Some (lev,cur)),_) ->
-          Snterml (Gram.Entry.obj eobj,constr_level lev)
-
-(** Binding general entry keys to symbol *)
-
-let rec symbol_of_prod_entry_key = function
-  | Alist1 s -> Slist1 (symbol_of_prod_entry_key s)
-  | Alist1sep (s,sep) ->
-      slist1sep (symbol_of_prod_entry_key s) (gram_token_of_string sep)
-  | Alist0 s -> Slist0 (symbol_of_prod_entry_key s)
-  | Alist0sep (s,sep) ->
-      slist0sep (symbol_of_prod_entry_key s) (gram_token_of_string sep)
-  | Aopt s -> Sopt (symbol_of_prod_entry_key s)
-  | Amodifiers s ->
-       Gram.srules'
-        [([], Gram.action (fun _loc -> []));
-         ([gram_token_of_string "(";
-           slist1sep (symbol_of_prod_entry_key s) (gram_token_of_string ",");
-           gram_token_of_string ")"],
-	   Gram.action (fun _ l _ _loc -> l))]
-  | Aself -> Sself
-  | Anext -> Snext
-  | Atactic 5 -> Snterm (Gram.Entry.obj Tactic.binder_tactic)
-  | Atactic n ->
-      Snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n)
-  | 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) ->
-    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
-  | _ -> failwith "level_of_snterml"
-
-(**********************************************************************)
-(* 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 && 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
-    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
-    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
-    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
-    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 && coincide s "_mods" (l-5) then
-    let t, g = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in
-    ListArgType t, Amodifiers g
-  else
-    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 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 -> 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 24b58775..37165f6c 100644
--- a/parsing/pcoq.mli
+++ b/parsing/pcoq.mli
@@ -14,13 +14,12 @@ open Genarg
 open Constrexpr
 open Tacexpr
 open Libnames
-open Compat
 open Misctypes
 open Genredexpr
 
 (** The parser of Coq *)
 
-module Gram : GrammarSig
+module Gram : module type of Compat.GrammarMake(CLexer)
 
 (** The parser of Coq is built from three kinds of rule declarations:
 
@@ -40,7 +39,7 @@ module Gram : GrammarSig
         |     (together with a constr entry level, e.g. 50, and indications of)
         |     (subentries, e.g. x in constr next level and y constr same level)
         |
-        | spliting into tokens by Metasyntax.split_notation_string
+        | splitting into tokens by Metasyntax.split_notation_string
         V
       [String "x"; String "+"; String "y"] : symbol_token list
         |
@@ -97,38 +96,7 @@ module Gram : GrammarSig
 
 *)
 
-val gram_token_of_token : Tok.t -> Gram.symbol
-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_reinit option (** for reinitialization if ever needed *) ->
-  Gram.extend_statment -> unit
-
-(** Remove the last n extensions *)
-val remove_grammars : int -> unit
-
-
-
-
-(** The type of typed grammar objects *)
-type typed_entry
-
-(** The possible types for extensible grammars *)
-type entry_type = argument_type
-
-val type_of_typed_entry : typed_entry -> entry_type
-val object_of_typed_entry : typed_entry -> grammar_object Gram.entry
-val weaken_entry : 'a Gram.entry -> grammar_object Gram.entry
-
-(** Temporary activate camlp4 verbosity *)
+(** Temporarily activate camlp4 verbosity *)
 
 val camlp4_verbosity : bool -> ('a -> unit) -> 'a -> unit
 
@@ -138,12 +106,8 @@ val parse_string : 'a Gram.entry -> string -> 'a
 val eoi_entry : 'a Gram.entry -> 'a Gram.entry
 val map_entry : ('a -> 'b) -> 'a Gram.entry -> 'b Gram.entry
 
-(** Table of Coq statically defined grammar entries *)
-
 type gram_universe
 
-(** There are four predefined universes: "prim", "constr", "tactic", "vernac" *)
-
 val get_univ : string -> gram_universe
 
 val uprim : gram_universe
@@ -151,9 +115,11 @@ val uconstr : gram_universe
 val utactic : gram_universe
 val uvernac : gram_universe
 
-val create_entry : gram_universe -> string -> entry_type -> typed_entry
-val create_generic_entry : string -> ('a, rlevel) abstract_argument_type ->
-  'a Gram.entry
+val register_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry -> unit
+val genarg_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry
+
+val create_generic_entry : gram_universe -> string ->
+  ('a, rlevel) abstract_argument_type -> 'a Gram.entry
 
 module Prim :
   sig
@@ -163,6 +129,7 @@ module Prim :
     val ident : Id.t Gram.entry
     val name : Name.t located Gram.entry
     val identref : Id.t located Gram.entry
+    val pidentref : (Id.t located * (Id.t located list) option) Gram.entry
     val pattern_ident : Id.t Gram.entry
     val pattern_identref : Id.t located Gram.entry
     val base_ident : Id.t Gram.entry
@@ -190,6 +157,7 @@ module Constr :
     val operconstr : constr_expr Gram.entry
     val ident : Id.t Gram.entry
     val global : reference Gram.entry
+    val universe_level : glob_level Gram.entry
     val sort : glob_sort Gram.entry
     val pattern : cases_pattern_expr Gram.entry
     val constr_pattern : constr_expr Gram.entry
@@ -212,7 +180,7 @@ module Module :
 
 module Tactic :
   sig
-    val open_constr : open_constr_expr Gram.entry
+    val open_constr : constr_expr Gram.entry
     val constr_with_bindings : constr_expr with_bindings Gram.entry
     val bindings : constr_expr bindings Gram.entry
     val hypident : (Id.t located * Locus.hyp_location_flag) Gram.entry
@@ -220,17 +188,18 @@ module Tactic :
     val constr_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 destruction_arg : constr_expr with_bindings destruction_arg Gram.entry
     val int_or_var : int or_var Gram.entry
     val red_expr : raw_red_expr Gram.entry
     val simple_tactic : raw_tactic_expr Gram.entry
     val simple_intropattern : constr_expr intro_pattern_expr located Gram.entry
+    val in_clause : Names.Id.t Loc.located Locus.clause_expr 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_ :
@@ -242,69 +211,57 @@ module Vernac_ :
     val vernac : vernac_expr Gram.entry
     val rec_definition : (fixpoint_expr * decl_notation list) Gram.entry
     val vernac_eoi : vernac_expr Gram.entry
+    val noedit_mode : vernac_expr Gram.entry
+    val command_entry : vernac_expr Gram.entry
+    val hint_info : Vernacexpr.hint_info_expr Gram.entry
   end
 
 (** The main entry: reads an optional vernac command *)
 val main_entry : (Loc.t * vernac_expr) option Gram.entry
 
-(** Mapping formal entries into concrete ones *)
-
-(** Binding constr entry keys to entries and symbols *)
-
-val interp_constr_entry_key : bool (** true for cases_pattern *) ->
-  constr_entry_key -> grammar_object Gram.entry * int option
+(** Handling of the proof mode entry *)
+val get_command_entry : unit -> vernac_expr Gram.entry
+val set_command_entry : vernac_expr Gram.entry -> unit
 
-val symbol_of_constr_prod_entry_key : gram_assoc option ->
-  constr_entry_key -> bool -> constr_prod_entry_key ->
-    Gram.symbol
+val epsilon_value : ('a -> 'self) -> ('self, 'a) Extend.symbol -> 'self option
 
-(** General entry keys *)
+(** {5 Extending the parser without synchronization} *)
 
-(** This intermediate abstract representation of entries can
-   both be reified into mlexpr for the ML extensions and
-   dynamically interpreted as entries for the Coq level extensions
-*)
-
-type prod_entry_key =
-  | Alist1 of prod_entry_key
-  | Alist1sep of prod_entry_key * string
-  | Alist0 of prod_entry_key
-  | Alist0sep of prod_entry_key * string
-  | Aopt of prod_entry_key
-  | Amodifiers of prod_entry_key
-  | Aself
-  | Anext
-  | Atactic of int
-  | Agram of string
-  | Aentry of string * string
-
-(** Binding general entry keys to symbols *)
+type gram_reinit = gram_assoc * gram_position
+(** Type of reinitialization data *)
 
-val symbol_of_prod_entry_key :
-  prod_entry_key -> Gram.symbol
+val grammar_extend : 'a Gram.entry -> gram_reinit option ->
+  'a Extend.extend_statment -> unit
+(** Extend the grammar of Coq, without synchronizing it with the backtracking
+    mechanism. This means that grammar extensions defined this way will survive
+    an undo. *)
 
-(** Interpret entry names of the form "ne_constr_list" as entry keys   *)
+(** {5 Extending the parser with summary-synchronized commands} *)
 
-val interp_entry_name : bool (** true to fail on unknown entry *) ->
-  int option -> string -> string -> entry_type * prod_entry_key
+module GramState : Store.S
+(** Auxiliary state of the grammar. Any added data must be marshallable. *)
 
-(** Recover the list of all known tactic notation entries. *)
-val list_entry_names : unit -> (string * entry_type) list
+type 'a grammar_command
+(** Type of synchronized parsing extensions. The ['a] type should be
+    marshallable. *)
 
-(** Registering/resetting the level of a constr entry *)
+type extend_rule =
+| ExtendRule : 'a Gram.entry * gram_reinit option * 'a extend_statment -> extend_rule
 
-val find_position :
-  bool (** true if for creation in pattern entry; false if in constr entry *) ->
-  Extend.gram_assoc option -> int option ->
-    Extend.gram_position option * Extend.gram_assoc option * string option *
-    (** for reinitialization: *) gram_reinit option
+type 'a grammar_extension = 'a -> GramState.t -> extend_rule list * GramState.t
+(** Grammar extension entry point. Given some ['a] and a current grammar state,
+    such a function must produce the list of grammar extensions that will be
+    applied in the same order and kept synchronized w.r.t. the summary, together
+    with a new state. It should be pure. *)
 
-val synchronize_level_positions : unit -> unit
+val create_grammar_command : string -> 'a grammar_extension -> 'a grammar_command
+(** Create a new grammar-modifying command with the given name. The extension
+    function is called to generate the rules for a given data. *)
 
-val register_empty_levels : bool -> int list ->
-    (Extend.gram_position option * Extend.gram_assoc option *
-     string option * gram_reinit option) list
+val extend_grammar_command : 'a grammar_command -> 'a -> unit
+(** Extend the grammar of Coq with the given data. *)
 
-val remove_levels : int -> unit
+val recover_grammar_command : 'a grammar_command -> 'a list
+(** Recover the current stack of grammar extensions. *)
 
-val level_of_snterml : Gram.symbol -> int
+val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b
diff --git a/parsing/tok.ml b/parsing/tok.ml
index c96b53de..f4b60aee 100644
--- a/parsing/tok.ml
+++ b/parsing/tok.ml
@@ -8,9 +8,10 @@
 
 (** The type of token for the Coq lexer and parser *)
 
+let string_equal (s1 : string) s2 = s1 = s2
+
 type t =
   | KEYWORD of string
-  | METAIDENT of string
   | PATTERNIDENT of string
   | IDENT of string
   | FIELD of string
@@ -21,16 +22,15 @@ type t =
   | EOI
 
 let equal t1 t2 = match t1, t2 with
-| IDENT s1, KEYWORD s2 -> CString.equal s1 s2
-| 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
+| IDENT s1, KEYWORD s2 -> string_equal s1 s2
+| KEYWORD s1, KEYWORD s2 -> string_equal s1 s2
+| PATTERNIDENT s1, PATTERNIDENT s2 -> string_equal s1 s2
+| IDENT s1, IDENT s2 -> string_equal s1 s2
+| FIELD s1, FIELD s2 -> string_equal s1 s2
+| INT s1, INT s2 -> string_equal s1 s2
+| STRING s1, STRING s2 -> string_equal s1 s2
 | LEFTQMARK, LEFTQMARK -> true
-| BULLET s1, BULLET s2 -> CString.equal s1 s2
+| BULLET s1, BULLET s2 -> string_equal s1 s2
 | EOI, EOI -> true
 | _ -> false
 
@@ -38,7 +38,6 @@ let extract_string = function
   | KEYWORD s -> s
   | IDENT s -> s
   | STRING s -> s
-  | METAIDENT s -> s
   | PATTERNIDENT s -> s
   | FIELD s -> s
   | INT s -> s
@@ -49,13 +48,12 @@ let extract_string = function
 let to_string = function
   | KEYWORD s -> Format.sprintf "%S" s
   | IDENT s -> Format.sprintf "IDENT %S" s
-  | METAIDENT s -> Format.sprintf "METAIDENT %S" s
   | PATTERNIDENT s -> Format.sprintf "PATTERNIDENT %S" s
   | FIELD s -> Format.sprintf "FIELD %S" s
   | INT s -> Format.sprintf "INT %s" s
   | STRING s -> Format.sprintf "STRING %S" s
   | LEFTQMARK -> "LEFTQMARK"
-  | BULLET s -> Format.sprintf "STRING %S" s
+  | BULLET s -> Format.sprintf "BULLET %S" s
   | EOI -> "EOI"
 
 let match_keyword kwd = function
@@ -72,7 +70,6 @@ let print ppf tok = Format.pp_print_string ppf (to_string tok)
 let of_pattern = function
   | "", s -> KEYWORD s
   | "IDENT", s -> IDENT s
-  | "METAIDENT", s -> METAIDENT s
   | "PATTERNIDENT", s -> PATTERNIDENT s
   | "FIELD", s -> FIELD s
   | "INT", s -> INT s
@@ -85,7 +82,6 @@ let of_pattern = function
 let to_pattern = function
   | KEYWORD s -> "", s
   | IDENT s -> "IDENT", s
-  | METAIDENT s -> "METAIDENT", s
   | PATTERNIDENT s -> "PATTERNIDENT", s
   | FIELD s -> "FIELD", s
   | INT s -> "INT", s
@@ -99,7 +95,6 @@ let match_pattern =
   function
     | "", "" -> (function KEYWORD s -> s | _ -> err ())
     | "IDENT", "" -> (function IDENT s -> s | _ -> err ())
-    | "METAIDENT", "" -> (function METAIDENT s -> s | _ -> err ())
     | "PATTERNIDENT", "" -> (function PATTERNIDENT s -> s | _ -> err ())
     | "FIELD", "" -> (function FIELD s -> s | _ -> err ())
     | "INT", "" -> (function INT s -> s | _ -> err ())
diff --git a/parsing/tok.mli b/parsing/tok.mli
index df006601..b9286c53 100644
--- a/parsing/tok.mli
+++ b/parsing/tok.mli
@@ -10,7 +10,6 @@
 
 type t =
   | KEYWORD of string
-  | METAIDENT of string
   | PATTERNIDENT of string
   | IDENT of string
   | FIELD of string
@@ -20,6 +19,7 @@ type t =
   | BULLET of string
   | EOI
 
+val equal : t -> t -> bool
 val extract_string : t -> string
 val to_string : t -> string
 (* Needed to fit Camlp4 signature *)
diff --git a/plugins/btauto/btauto_plugin.mllib b/plugins/btauto/btauto_plugin.mlpack
index 319a9c30..2410f906 100644
--- a/plugins/btauto/btauto_plugin.mllib
+++ b/plugins/btauto/btauto_plugin.mlpack
@@ -1,3 +1,2 @@
 Refl_btauto
 G_btauto
-Btauto_plugin_mod
diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml
index 57268a9c..6e8b2eb0 100644
--- a/plugins/btauto/refl_btauto.ml
+++ b/plugins/btauto/refl_btauto.ml
@@ -1,3 +1,4 @@
+open Proofview.Notations
 
 let contrib_name = "btauto"
 
@@ -11,7 +12,7 @@ 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 ()))
+  Lazy.from_fun (fun () -> Globnames.destIndRef (glob_ref ()))
 
 let decomp_term (c : Term.constr) =
   Term.kind_of_term (Term.strip_outer_cast c)
@@ -211,12 +212,12 @@ module Btauto = struct
         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")
+      with e when CErrors.noncritical e -> (str "Not a tautology")
     in
     Tacticals.tclFAIL 0 msg gl
 
   let try_unification env =
-    Proofview.Goal.nf_enter begin fun gl ->
+    Proofview.Goal.nf_enter { enter = begin fun gl ->
       let concl = Proofview.Goal.concl gl in
       let eq = Lazy.force eq in
       let t = decomp_term concl in
@@ -228,10 +229,10 @@ module Btauto = struct
       | _ ->
           let msg = str "Btauto: Internal error" in
           Tacticals.New.tclFAIL 0 msg
-    end
+    end }
 
   let tac =
-    Proofview.Goal.nf_enter begin fun gl ->
+    Proofview.Goal.nf_enter { enter = begin fun gl ->
       let concl = Proofview.Goal.concl gl in
       let eq = Lazy.force eq in
       let bool = Lazy.force Bool.typ in
@@ -249,12 +250,12 @@ module Btauto = struct
           Tacticals.New.tclTHENLIST [
             Tactics.change_concl changed_gl;
             Tactics.apply (Lazy.force soundness);
-            Proofview.V82.tactic (Tactics.normalise_vm_in_concl);
+            Tactics.normalise_vm_in_concl;
             try_unification env
           ]
       | _ ->
           let msg = str "Cannot recognize a boolean equality" in
           Tacticals.New.tclFAIL 0 msg
-    end
+    end }
 
 end
diff --git a/plugins/cc/cc_plugin.mllib b/plugins/cc/cc_plugin.mlpack
index 1bcfc537..27e903fd 100644
--- a/plugins/cc/cc_plugin.mllib
+++ b/plugins/cc/cc_plugin.mlpack
@@ -2,4 +2,3 @@ Ccalgo
 Ccproof
 Cctac
 G_congruence
-Cc_plugin_mod
diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml
index bc3d9ed5..bc53b113 100644
--- a/plugins/cc/ccalgo.ml
+++ b/plugins/cc/ccalgo.ml
@@ -10,7 +10,7 @@
 (* Downey,Sethi and Tarjan. *)
 (* Plus some e-matching and constructor handling by P. Corbineau *)
 
-open Errors
+open CErrors
 open Util
 open Pp
 open Goptions
@@ -25,7 +25,7 @@ let init_size=5
 let cc_verbose=ref false
 
 let debug x =
-  if !cc_verbose then msg_debug x
+  if !cc_verbose then Feedback.msg_debug (x ())
 
 let _=
   let gdopt=
@@ -154,11 +154,6 @@ let rec term_equal t1 t2 =
 
 open Hashset.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 (Sorts.hash s1) (Sorts.hash s2)
@@ -489,7 +484,7 @@ let build_subst uf subst =
   Array.map
     (fun i ->
       try term uf i
-      with e when Errors.noncritical e ->
+      with e when CErrors.noncritical e ->
         anomaly (Pp.str "incomplete matching"))
     subst
 
@@ -603,7 +598,7 @@ let add_inst state (inst,int_subst) =
   Control.check_for_interrupt ();
   if state.rew_depth > 0 then
   if is_redundant state inst.qe_hyp_id int_subst then
-    debug (str "discarding redundant (dis)equality")
+    debug (fun () -> str "discarding redundant (dis)equality")
   else
     begin
       Identhash.add state.q_history inst.qe_hyp_id int_subst;
@@ -618,7 +613,7 @@ let add_inst state (inst,int_subst) =
 	    state.rew_depth<-pred state.rew_depth;
 	    if inst.qe_pol then
 	      begin
-		debug (
+		debug (fun () ->
 		   (str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++
 	          (str "  [" ++ Termops.print_constr prf ++ str " : " ++
 			   pr_term s ++ str " == " ++ pr_term t ++ str "]"));
@@ -626,7 +621,7 @@ let add_inst state (inst,int_subst) =
 	      end
 	    else
 	      begin
-		debug (
+		debug (fun () ->
 		   (str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++
 	          (str "  [" ++ Termops.print_constr prf ++ str " : " ++
 			   pr_term s ++ str " <> " ++ pr_term t ++ str "]"));
@@ -657,7 +652,7 @@ let join_path uf i j=
   min_path (down_path uf i [],down_path uf j [])
 
 let union state i1 i2 eq=
-  debug (str "Linking " ++ pr_idx_term state.uf i1 ++
+  debug (fun () -> 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
@@ -698,7 +693,7 @@ let union state i1 i2 eq=
 
 let merge eq state = (* merge and no-merge *)
   debug
-    (str "Merging " ++ pr_idx_term state.uf eq.lhs ++
+    (fun () -> 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
@@ -711,7 +706,7 @@ let merge eq state = (* merge and no-merge *)
 
 let update t state = (* update 1 and 2 *)
   debug
-    (str "Updating term " ++ pr_idx_term state.uf t ++ str ".");
+    (fun () -> 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
@@ -773,7 +768,7 @@ let process_constructor_mark t i rep pac state =
 
 let process_mark t m state =
   debug
-    (str "Processing mark for term " ++ pr_idx_term state.uf t ++ str ".");
+    (fun () -> 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
@@ -794,7 +789,7 @@ let check_disequalities state =
           else (str "No", check_aux q)
         in
         let _ = debug
-        (str "Checking if " ++ pr_idx_term state.uf dis.lhs ++ str " = " ++
+        (fun () -> str "Checking if " ++ pr_idx_term state.uf dis.lhs ++ str " = " ++
          pr_idx_term state.uf dis.rhs ++ str " ... " ++ info) in
         ans
     | [] -> None
@@ -824,7 +819,7 @@ let __eps__ = Id.of_string "_eps_"
 let new_state_var typ state =
   let id = pf_get_new_id __eps__ state.gls in
   let {it=gl ; sigma=sigma} = state.gls in
-  let gls = Goal.V82.new_goal_with sigma gl [id,None,typ] in
+  let gls = Goal.V82.new_goal_with sigma gl [Context.Named.Declaration.LocalAssum (id,typ)] in
     state.gls<- gls;
     id
 
@@ -979,7 +974,7 @@ let find_instances state =
   let pb_stack= init_pb_stack state in
   let res =ref [] in
   let _ =
-    debug (str "Running E-matching algorithm ... ");
+    debug (fun () -> str "Running E-matching algorithm ... ");
     try
       while true do
 	Control.check_for_interrupt ();
@@ -990,7 +985,7 @@ let find_instances state =
     !res
 
 let rec execute first_run state =
-  debug (str "Executing ... ");
+  debug (fun () -> str "Executing ... ");
   try
     while
       Control.check_for_interrupt ();
@@ -1000,7 +995,7 @@ let rec execute first_run state =
 	None ->
 	  if not(Int.Set.is_empty state.pa_classes) then
 	    begin
-	      debug (str "First run was incomplete, completing ... ");
+	      debug (fun () -> str "First run was incomplete, completing ... ");
 	      complete state;
 	      execute false state
 	    end
@@ -1015,12 +1010,12 @@ let rec execute first_run state =
 		  end
 		else
 	      begin
-		debug (str "Out of instances ... ");
+		debug (fun () -> str "Out of instances ... ");
 		None
 	      end
 	    else
 	      begin
-		debug (str "Out of depth ... ");
+		debug (fun () -> str "Out of depth ... ");
 		None
 	      end
       | Some dis -> Some
diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli
index b73c8eef..c7fa2f56 100644
--- a/plugins/cc/ccalgo.mli
+++ b/plugins/cc/ccalgo.mli
@@ -120,7 +120,7 @@ val term_equal : term -> term -> bool
 
 val constr_of_term : term -> constr
 
-val debug : Pp.std_ppcmds -> unit
+val debug : (unit -> Pp.std_ppcmds) -> unit
 
 val forest : state -> forest
 
diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml
index c188bf3b..f58847ca 100644
--- a/plugins/cc/ccproof.ml
+++ b/plugins/cc/ccproof.ml
@@ -9,7 +9,7 @@
 (* This file uses the (non-compressed) union-find structure to generate *)
 (* proof-trees that will be transformed into proof-terms in cctac.ml4   *)
 
-open Errors
+open CErrors
 open Term
 open Ccalgo
 open Pp
@@ -93,13 +93,13 @@ let pinject p c n a =
    p_rule=Inject(p,c,n,a)}
 
 let rec equal_proof uf i j=
-  debug (str "equal_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j);
+  debug (fun () -> 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);
+  debug (fun () -> 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=
@@ -115,7 +115,7 @@ and edge_proof uf ((i,j),eq)=
   ptrans (ptrans pi pij) pj
   
 and constr_proof uf i ipac=
-  debug (str "constr_proof " ++ pr_idx_term uf i ++ brk (1,20));
+  debug (fun () -> 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
@@ -128,20 +128,20 @@ and constr_proof uf i ipac=
     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 "{" ++
+  debug (fun () -> 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);
+  debug (fun () -> 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);
+   debug (fun () -> 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
diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml
index 0baa5337..fd46d806 100644
--- a/plugins/cc/cctac.ml
+++ b/plugins/cc/cctac.ml
@@ -20,8 +20,10 @@ open Typing
 open Ccalgo
 open Ccproof
 open Pp
-open Errors
+open CErrors
 open Util
+open Proofview.Notations
+open Context.Rel.Declaration
 
 let reference dir s = lazy (Coqlib.gen_reference "CC" dir s)
 
@@ -36,17 +38,17 @@ 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
-    (fun t -> Closure.whd_val infos (Closure.inject t))
+  let infos=CClosure.create_clos_infos CClosure.betaiotazeta env in
+    (fun t -> CClosure.whd_val infos (CClosure.inject t))
 
 let whd_delta env=
-   let infos=Closure.create_clos_infos Closure.betadeltaiota env in
-    (fun t -> Closure.whd_val infos (Closure.inject t))
+   let infos=CClosure.create_clos_infos CClosure.all env in
+    (fun t -> CClosure.whd_val infos (CClosure.inject t))
 
 (* decompose member of equality in an applicative format *)
 
 (** FIXME: evar leak *)
-let sf_of env sigma c = sort_of env (ref sigma) c
+let sf_of env sigma c = e_sort_of env (ref sigma) c
 
 let rec decompose_term env sigma t=
     match kind_of_term (whd env t) with
@@ -80,8 +82,10 @@ let rec decompose_term env sigma t=
     | 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
+	(Appli (Symb (mkConst (Projection.constant p')), decompose_term env sigma c))
+    | _ ->
+       let t = strip_outer_cast t in
+       if closed0 t then Symb t else raise Not_found
 
 (* decompose equality in members and type *)
 open Globnames
@@ -151,7 +155,7 @@ let rec quantified_atom_of_constr env sigma nrels term =
 	  let patts=patterns_of_constr env sigma nrels atom in
 	      `Nrule patts
 	else 
-	  quantified_atom_of_constr (Environ.push_rel (id,None,atom) env) sigma (succ nrels) ff
+	  quantified_atom_of_constr (Environ.push_rel (LocalAssum (id,atom)) env) sigma (succ nrels) ff
     | _ ->  
 	let patts=patterns_of_constr env sigma nrels term in
 	    `Rule patts
@@ -166,7 +170,7 @@ let litteral_of_constr env sigma term=
 	else
 	  begin
 	    try 
-	      quantified_atom_of_constr (Environ.push_rel (id,None,atom) env) sigma 1 ff  
+	      quantified_atom_of_constr (Environ.push_rel (LocalAssum (id,atom)) env) sigma 1 ff
 	    with Not_found ->
 	      `Other (decompose_term env sigma term)
 	  end
@@ -187,7 +191,8 @@ let make_prb gls depth additionnal_terms =
 	 let t = decompose_term env sigma c in
 	   ignore (add_term state t)) additionnal_terms;
     List.iter
-      (fun (id,_,e) ->
+      (fun decl ->
+         let (id,_,e) = Context.Named.Declaration.to_tuple decl in
 	 begin
 	   let cid=mkVar id in
 	   match litteral_of_constr env sigma e with
@@ -220,24 +225,9 @@ let make_prb gls depth additionnal_terms =
 
 (* indhyps builds the array of arrays of constructor hyps for (ind largs) *)
 
-let build_projection intype outtype (cstr:pconstructor) special default gls=
-  let env=pf_env gls 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(fst cstr)) in
-  let branch i=
-    let ti= prod_appvect types.(i) argv in
-    let rc=fst (decompose_prod_assum ti) in
-    let head=
-      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 build_projection intype (cstr:pconstructor) special default gls=
+  let ci= (snd(fst cstr)) in
+  let body=Equality.build_selector (pf_env gls) (project gls) ci (mkRel 1) intype special default in
   let id=pf_get_new_id (Id.of_string "t") gls in
     mkLambda(Name id,intype,body)
 
@@ -245,22 +235,34 @@ let build_projection intype outtype (cstr:pconstructor) special default gls=
 
 let _M =mkMeta
 
-let app_global f args k = 
+let app_global f args k =
   Tacticals.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (fc, args)))
 
-let new_app_global f args k = 
+let new_app_global f args k =
   Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (fc, args)))
 
 let new_refine c = Proofview.V82.tactic (refine c)
 
 let assert_before n c =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
     let evm, _ = Tacmach.New.pf_apply type_of gl c in
       Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (assert_before n c)
-  end
-    
+  end }
+
+let refresh_type env evm ty =
+  Evarsolve.refresh_universes ~status:Evd.univ_flexible ~refreshset:true
+			      (Some false) env evm ty
+
+let refresh_universes ty k =
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let evm = Tacmach.New.project gl in
+    let evm, ty = refresh_type env evm ty in
+    Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (k ty)
+  end }
+
 let rec proof_tac p : unit Proofview.tactic =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let type_of t = Tacmach.New.pf_unsafe_type_of gl t in
   try (* type_of can raise exceptions *)
   match p.p_rule with
@@ -268,35 +270,31 @@ let rec proof_tac p : unit Proofview.tactic =
     | SymAx c ->
 	let l=constr_of_term p.p_lhs and
 	    r=constr_of_term p.p_rhs in
-        let typ = (* Termops.refresh_universes *) type_of l in
-        new_app_global _sym_eq [|typ;r;l;c|] exact_check
+	refresh_universes (type_of l) (fun typ ->
+        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 *) type_of lr in
-        new_app_global _refl_equal [|typ;constr_of_term t|] exact_check
+	refresh_universes (type_of lr) (fun typ ->
+        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 *) (type_of t2) in
+	refresh_universes (type_of t2) (fun typ ->
 	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)]
+          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  *)(type_of tf1) in
-	let typx = (* Termops.refresh_universes *) (type_of tx1) in
-	let typfx = (* Termops.refresh_universes *) (type_of (mkApp (tf1,[|tx1|]))) in
+	refresh_universes (type_of tf1) (fun typf ->
+	refresh_universes (type_of tx1) (fun typx ->
+	refresh_universes (type_of (mkApp (tf1,[|tx1|]))) (fun typfx ->
         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 =
-	  app_global _f_equal
-		[|typf;typfx;appx1;tf1;tf2;_M 1|] in
-	let lemma2=
-	  app_global _f_equal
-		[|typx;typfx;tf2;tx1;tx2;_M 1|] in
+	let lemma1 = app_global _f_equal [|typf;typfx;appx1;tf1;tf2;_M 1|] in
+	let lemma2 = app_global _f_equal [|typx;typfx;tf2;tx1;tx2;_M 1|] in
 	let prf =
 	  app_global _trans_eq
 		[|typfx;
@@ -310,96 +308,89 @@ let rec proof_tac p : unit Proofview.tactic =
 		reflexivity;
                 Tacticals.New.tclZEROMSG
 		    (Pp.str
-		       "I don't know how to handle dependent equality")]]
+		       "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 *) (type_of ti) in
-	 let outtype = (* Termops.refresh_universes *) (type_of default) in
 	 let special=mkRel (1+nargs-argind) in
+	 refresh_universes (type_of ti) (fun intype ->
+         refresh_universes (type_of default) (fun outtype ->
          let proj =
-           Tacmach.New.of_old (build_projection intype outtype cstr special default) gl
+           Tacmach.New.of_old (build_projection intype cstr special default) gl
          in
 	 let injt=
            app_global _f_equal [|intype;outtype;proj;ti;tj;_M 1|] in
-	   Tacticals.New.tclTHEN (Proofview.V82.tactic (injt refine)) (proof_tac prf)
+	   Tacticals.New.tclTHEN (Proofview.V82.tactic (injt refine)) (proof_tac prf)))
   with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
-  end
+  end }
 
 let refute_tac c t1 t2 p =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
-  let intype =
-    Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_unsafe_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
+  let k intype =
+    let neweq= new_app_global _eq [|intype;tt1;tt2|] in
     Tacticals.New.tclTHENS (neweq (assert_before (Name hid)))
       [proof_tac p; simplest_elim false_t]
-  end
+  in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt1) k
+  end }
 
 let refine_exact_check c gl =
   let evm, _ = pf_apply 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 ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
-  let sort =
-    Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_unsafe_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=app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in
+  let k sort =
+    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=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
+			   [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)]
+  in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt2) k
+  end }
 
 let convert_to_hyp_tac c1 t1 c2 t2 p =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let tt2=constr_of_term t2 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
     Tacticals.New.tclTHENS (assert_before (Name h) tt2)
       [convert_to_goal_tac c1 t1 t2 p;
        simplest_elim false_t]
-  end
+  end }
 
 let discriminate_tac (cstr,u as cstru) p =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { 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_unsafe_type_of gls t1)) gl
-    in
+    let env = Proofview.Goal.env 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 (Lazy.force _I) in
-    (* let trivial=pf_unsafe_type_of gls identity in *)
     let trivial = Universes.constr_of_global (Lazy.force _True) in
-    let evm, outtype = Evd.new_sort_variable Evd.univ_flexible (Proofview.Goal.sigma gl) in 
+    let evm = Tacmach.New.project gl in
+    let evm, intype = refresh_type env evm (Tacmach.New.pf_unsafe_type_of gl t1) in
+    let evm, outtype = Evd.new_sort_variable Evd.univ_flexible evm in
     let outtype = mkSort outtype in
-    let pred=mkLambda(Name xid,outtype,mkRel 1) 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 proj = Tacmach.New.of_old (build_projection intype cstru trivial concl) gl in
     let injt=app_global _f_equal
-                    [|intype;outtype;proj;t1;t2;mkVar hid|] in
+			[|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
+            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
+			  (Tacticals.New.tclTHENS (neweq (assert_before (Name hid)))
+      [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)])
+  end }
 
 (* wrap everything *)
 
@@ -411,18 +402,18 @@ let build_term_to_complete uf meta pac =
     applistc (mkConstructU cinfo.ci_constr) all_args
 
 let cc_tactic depth additionnal_terms =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
     Coqlib.check_required_library Coqlib.logic_module_name;
-    let _ = debug (Pp.str "Reading subgoal ...") in
+    let _ = debug (fun () -> 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 _ = debug (fun () -> Pp.str "Problem built, solving ...") in
     let sol = execute true state in
-    let _ = debug (Pp.str "Computation completed.") in
+    let _ = debug (fun () -> Pp.str "Computation completed.") in
     let uf=forest state in
     match sol with
       None -> Tacticals.New.tclFAIL 0 (str "congruence failed")
     | Some reason ->
-	debug (Pp.str "Goal solved, generating proof ...");
+	debug (fun () -> 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
@@ -436,10 +427,10 @@ let cc_tactic depth additionnal_terms =
 	      List.map
 		(build_term_to_complete uf newmeta)
 		(epsilons uf) in
-	    Pp.msg_info
+	    Feedback.msg_info
 	      (Pp.str "Goal is solvable by congruence but \
  some arguments are missing.");
-	    Pp.msg_info
+	    Feedback.msg_info
 	      (Pp.str "  Try " ++
 		 hov 8
 		 begin
@@ -462,7 +453,7 @@ let cc_tactic depth additionnal_terms =
 		convert_to_goal_tac id ta tb p
 	    | HeqnH (ida,idb) ->
 		convert_to_hyp_tac ida ta idb tb p
-  end
+  end }
 
 let cc_fail gls =
   errorlabstrm  "Congruence" (Pp.str "congruence failed.")
@@ -482,11 +473,10 @@ let congruence_tac depth l =
    This isn't particularly related with congruence, apart from
    the fact that congruence is called internally.
 *)
-    
+
 let mk_eq f c1 c2 k =
   Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc ->
-  Proofview.Goal.enter begin
-    fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
     let open Tacmach.New in
     let evm, ty = pf_apply type_of gl c1 in
     let evm, ty = Evarsolve.refresh_universes (Some false) (pf_env gl) evm ty in
@@ -494,10 +484,10 @@ let mk_eq f c1 c2 k =
     let evm, _ =  type_of (pf_env gl) evm term in
     Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm))
 			  (k term)
-    end)
-    
+    end })
+
 let f_equal =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
     let concl = Proofview.Goal.concl gl in
     let cut_eq c1 c2 =
       try (* type_of can raise an exception *)
@@ -523,4 +513,4 @@ let f_equal =
         | Type_errors.TypeError _ -> Proofview.tclUNIT ()
         | e -> Proofview.tclZERO ~info e
       end
-  end
+  end }
diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4
index 5dbc340c..52a13511 100644
--- a/plugins/cc/g_congruence.ml4
+++ b/plugins/cc/g_congruence.ml4
@@ -9,6 +9,8 @@
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
 open Cctac
+open Stdarg
+open Constrarg
 
 DECLARE PLUGIN "cc_plugin"
 
diff --git a/plugins/decl_mode/decl_expr.mli b/plugins/decl_mode/decl_expr.mli
index 79ef3d18..29ecb94c 100644
--- a/plugins/decl_mode/decl_expr.mli
+++ b/plugins/decl_mode/decl_expr.mli
@@ -99,4 +99,4 @@ type proof_instr =
     (Term.constr statement,
      Term.constr,
      proof_pattern,
-     Tacexpr.glob_tactic_expr) gen_proof_instr
+     Geninterp.Val.t) gen_proof_instr
diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml
index 2a44dca2..a862423e 100644
--- a/plugins/decl_mode/decl_interp.ml
+++ b/plugins/decl_mode/decl_interp.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Constrexpr
@@ -96,7 +96,7 @@ let rec add_vars_of_simple_pattern globs = function
       add_vars_of_simple_pattern globs p
   | CPatCstr (_,_,pl1,pl2) ->
     List.fold_left add_vars_of_simple_pattern
-      (List.fold_left add_vars_of_simple_pattern globs pl1) pl2
+      (Option.fold_left (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
@@ -153,8 +153,8 @@ let interp_constr check_sort env sigma 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 infos=CClosure.create_clos_infos CClosure.all env in
+    (fun t -> CClosure.whd_val infos (CClosure.inject t))
 
 let _eq = lazy (Universes.constr_of_global (Coqlib.glob_eq))
 
@@ -384,7 +384,7 @@ let interp_cases info env sigma params (pat:cases_pattern_expr) hyps =
 
 let interp_cut interp_it env sigma cut=
   let nenv,nstat = interp_it env sigma cut.cut_stat in
-    {cut with
+    { cut_using=Option.map (Tacinterp.Value.of_closure (Tacinterp.default_ist ())) cut.cut_using;
        cut_stat=nstat;
        cut_by=interp_justification_items nenv sigma cut.cut_by}
 
@@ -403,7 +403,7 @@ let interp_suffices_clause env sigma (hyps,cot)=
     match hyp with
 	(Hprop st | Hvar st) ->
 	  match st.st_label with
-	      Name id -> Environ.push_named (id,None,st.st_it) env0
+	      Name id -> Environ.push_named (Context.Named.Declaration.LocalAssum (id,st.st_it)) env0
 	    | _ -> env in
   let nenv = List.fold_right push_one locvars env in
     nenv,res
diff --git a/plugins/decl_mode/decl_mode.ml b/plugins/decl_mode/decl_mode.ml
index acee3d6c..92d40890 100644
--- a/plugins/decl_mode/decl_mode.ml
+++ b/plugins/decl_mode/decl_mode.ml
@@ -9,7 +9,7 @@
 open Names
 open Term
 open Evd
-open Errors
+open CErrors
 open Util
 
 let daimon_flag = ref false
@@ -116,7 +116,7 @@ let get_top_stack pts =
 let get_stack pts = Proof.get_at_focus proof_focus pts
 
 let get_last env = match Environ.named_context env with
-  | (id,_,_)::_ -> id
+  | decl :: _ -> Context.Named.Declaration.get_id decl
   | [] -> error "no previous statement to use"
 
 
diff --git a/plugins/decl_mode/decl_mode_plugin.mllib b/plugins/decl_mode/decl_mode_plugin.mlpack
index 39342dbd..1b84a079 100644
--- a/plugins/decl_mode/decl_mode_plugin.mllib
+++ b/plugins/decl_mode/decl_mode_plugin.mlpack
@@ -3,4 +3,3 @@ Decl_interp
 Decl_proof_instr
 Ppdecl_proof
 G_decl_mode
-Decl_mode_plugin_mod
diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml
index ba9fb728..d30fcf60 100644
--- a/plugins/decl_mode/decl_proof_instr.ml
+++ b/plugins/decl_mode/decl_proof_instr.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Pp
 open Evd
@@ -29,9 +29,27 @@ open Termops
 open Namegen
 open Goptions
 open Misctypes
+open Sigma.Notations
+open Context.Named.Declaration
 
 (* Strictness option *)
 
+let clear ids { it = goal; sigma } =
+  let ids = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty ids in
+  let env = Goal.V82.env sigma goal in
+  let sign = Goal.V82.hyps sigma goal in
+  let cl = Goal.V82.concl sigma goal in
+  let evdref = ref (Evd.clear_metas sigma) in
+  let (hyps, concl) =
+    try Evarutil.clear_hyps_in_evi env evdref sign cl ids
+    with Evarutil.ClearDependencyError (id, _) ->
+      errorlabstrm "" (str "Cannot clear " ++ pr_id id)
+  in
+  let sigma = !evdref in
+  let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in
+  let sigma = Goal.V82.partial_solution_to sigma goal gl ev in
+  { it = [gl]; sigma }
+
 let get_its_info gls = get_info gls.sigma gls.it
 
 let get_strictness,set_strictness =
@@ -42,7 +60,7 @@ let _ =
   declare_bool_option
     { optsync  = true;
       optdepr  = false;
-      optname  = "strict mode";
+      optname  = "strict proofs";
       optkey   = ["Strict";"Proofs"];
       optread  = get_strictness;
       optwrite = set_strictness }
@@ -66,12 +84,12 @@ let tcl_erase_info gls =
   tcl_change_info_gen info_gen gls
 
 let special_whd gl=
-  let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in
-    (fun t -> Closure.whd_val infos (Closure.inject t))
+  let infos=CClosure.create_clos_infos CClosure.all (pf_env gl) in
+    (fun t -> CClosure.whd_val infos (CClosure.inject t))
 
 let special_nf gl=
-  let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in
-    (fun t -> Closure.norm_val infos (Closure.inject t))
+  let infos=CClosure.create_clos_infos CClosure.betaiotazeta (pf_env gl) in
+    (fun t -> CClosure.norm_val infos (CClosure.inject t))
 
 let is_good_inductive env ind =
   let mib,oib = Inductive.lookup_mind_specif env ind in
@@ -86,7 +104,7 @@ Please \"suppose\" something or \"end\" it now."
       | _ -> ()
 
 let mk_evd metalist gls =
-  let evd0= create_goal_evar_defs (sig_sig gls) in
+  let evd0= clear_metas (sig_sig gls) in
   let add_one (meta,typ) evd =
     meta_declare meta typ evd in
     List.fold_right add_one metalist evd0
@@ -151,7 +169,7 @@ let do_daimon () =
       daimon_instr env p
     end
   in
-  if not status then Pp.feedback Feedback.AddedAxiom else ()
+  if not status then Feedback.feedback Feedback.AddedAxiom else ()
 
 (* post-instruction focus management *)
 
@@ -228,7 +246,8 @@ let close_previous_case pts =
 (* automation *)
 
 let filter_hyps f gls =
-  let filter_aux (id,_,_) =
+  let filter_aux id =
+    let id = get_id id in
     if f id then
       tclIDTAC
     else
@@ -258,12 +277,16 @@ let prepare_goal items gls =
        filter_hyps (let keep = !tokeep in fun id -> Id.Set.mem id keep)] gls
 
 let my_automation_tac = ref
-  (Proofview.tclZERO (Errors.make_anomaly (Pp.str"No automation registered")))
+  (Proofview.tclZERO (CErrors.make_anomaly (Pp.str"No automation registered")))
 
 let register_automation_tac tac = my_automation_tac:= tac
 
 let automation_tac = Proofview.tclBIND (Proofview.tclUNIT ()) (fun () -> !my_automation_tac)
 
+let warn_insufficient_justification =
+  CWarnings.create ~name:"declmode-insufficient-justification" ~category:"declmode"
+    (fun () -> strbrk "Insufficient justification.")
+
 let justification tac gls=
     tclORELSE
       (tclSOLVE [tclTHEN tac (Proofview.V82.of_tactic assumption)])
@@ -272,7 +295,7 @@ let justification tac gls=
 	   error "Insufficient justification."
 	 else
 	   begin
-	     msg_warning (str "Insufficient justification.");
+             warn_insufficient_justification ();
 	     daimon_tac gls
 	   end) gls
 
@@ -330,11 +353,12 @@ let enstack_subsubgoals env se stack gls=
 	    let rc,_ = Reduction.dest_prod env apptype in
 	    let rec meta_aux last lenv = function
 		[] -> (last,lenv,[])
-	      | (nam,_,typ)::q ->
+	      | decl::q ->
 		  let nlast=succ last in
 		  let (llast,holes,metas) =
 		    meta_aux nlast (mkMeta nlast :: lenv) q in
-		    (llast,holes,(nlast,special_nf gls (substl lenv typ))::metas) in
+                    let open Context.Rel.Declaration in
+		    (llast,holes,(nlast,special_nf gls (substl lenv (get_type decl)))::metas) in
 	    let (nlast,holes,nmetas) =
 		meta_aux se.se_last_meta [] (List.rev rc) in
 	    let refiner = applist (appterm,List.rev holes) in
@@ -391,7 +415,7 @@ let find_subsubgoal c ctyp skip submetas gls =
 		  se.se_meta submetas se.se_meta_list}
 	  else
 	      dfs (pred n)
-      with e when Errors.noncritical e ->
+      with e when CErrors.noncritical e ->
 	begin
 	  enstack_subsubgoals env se stack gls;
 	  dfs n
@@ -403,15 +427,15 @@ 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 (ref evd) concl) in
+  let sort = family_of_sort (Typing.e_sort_of env (ref evd) concl) in
   let rec aux env avoid subst = function
       [] -> 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 (ref evd) _A) in
+	let nenv = Environ.push_named (LocalAssum (_x,_A)) env in
+	let asort = family_of_sort (Typing.e_sort_of nenv (ref evd) _A) in
 	let nsubst = (n,mkVar _x)::subst in
 	  if List.is_empty rest then
 	    asort,_A,mkNamedLambda _x _A (subst_meta nsubst body)
@@ -465,7 +489,7 @@ let thus_tac c ctyp submetas gls =
     Proofview.V82.of_tactic (exact_check proof) gls
   else
     let refiner = concl_refiner list proof gls in
-      Tactics.refine refiner gls
+      Tacmach.refine refiner gls
 
 (* general forward step *)
 
@@ -492,7 +516,7 @@ let just_tac _then cut info gls0 =
         None ->
 	  Proofview.V82.of_tactic automation_tac gls
       | Some tac ->
-	  Proofview.V82.of_tactic (Tacinterp.eval_tactic tac) gls in
+	  Proofview.V82.of_tactic (Tacinterp.tactic_of_value (Tacinterp.default_ist ()) tac) gls in
     justification (tclTHEN items_tac method_tac) gls0
 
 let instr_cut mkstat _thus _then cut gls0 =
@@ -542,7 +566,7 @@ let instr_rew _thus rew_side cut gls0 =
         None ->
 	  Proofview.V82.of_tactic automation_tac gls
       | Some tac ->
-	  Proofview.V82.of_tactic (Tacinterp.eval_tactic tac) gls in
+	  Proofview.V82.of_tactic (Tacinterp.tactic_of_value (Tacinterp.default_ist ()) 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
@@ -605,7 +629,7 @@ let assume_tac hyps gls =
        tclTHEN
 	 (push_intro_tac
 	    (fun id ->
-	       Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it))) st.st_label))
+	       Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) st.st_label))
 	 hyps tclIDTAC gls
 
 let assume_hyps_or_theses hyps gls =
@@ -615,7 +639,7 @@ let assume_hyps_or_theses hyps gls =
 	   tclTHEN
 	     (push_intro_tac
 		(fun id ->
-		   Proofview.V82.of_tactic (convert_hyp (id,None,c))) nam)
+		   Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,c)))) nam)
        | Hprop {st_label=nam;st_it=Thesis (tk)} ->
 	   tclTHEN
 	     (push_intro_tac
@@ -627,7 +651,7 @@ let assume_st hyps gls =
     (fun st ->
        tclTHEN
 	 (push_intro_tac
-	    (fun id -> Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it))) st.st_label))
+	    (fun id -> Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) st.st_label))
 	 hyps tclIDTAC gls
 
 let assume_st_letin hyps gls =
@@ -636,7 +660,7 @@ let assume_st_letin hyps gls =
        tclTHEN
 	 (push_intro_tac
 	    (fun id ->
-	       Proofview.V82.of_tactic (convert_hyp (id,Some (fst st.st_it),snd st.st_it))) st.st_label))
+	       Proofview.V82.of_tactic (convert_hyp (LocalDef (id, fst st.st_it, snd st.st_it)))) st.st_label))
 	 hyps tclIDTAC gls
 
 (* suffices *)
@@ -730,7 +754,7 @@ 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 (Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it)))
+	tclIFTHENELSE (Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it))))
 	  begin
 	    match st.st_label with
 		Anonymous ->
@@ -798,8 +822,8 @@ let define_tac id args body gls =
 let cast_tac id_or_thesis typ gls =
   match id_or_thesis with
       This id ->
-	let (_,body,_) = pf_get_hyp gls id in
-	  Proofview.V82.of_tactic (convert_hyp (id,body,typ)) gls
+	let body = pf_get_hyp gls id |> get_value in
+	  Proofview.V82.of_tactic (convert_hyp (of_tuple (id,body,typ))) gls
     | Thesis (For _ ) ->
 	error "\"thesis for ...\" is not applicable here."
     | Thesis Plain ->
@@ -1199,6 +1223,9 @@ let hrec_for fix_id per_info gls obj_id =
   let hd2 = applist (mkVar fix_id,args@[obj]) in
     compose_lam rc (Reductionops.whd_beta gls.sigma hd2)
 
+let warn_missing_case =
+  CWarnings.create ~name:"declmode-missing-case" ~category:"declmode"
+    (fun () -> strbrk "missing case")
 
 let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
   match tree, objs  with
@@ -1269,12 +1296,12 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
 		       (fun id ->
 			  hrec_for (out_name fix_name) per_info gls1 id)
 		       recs in
-		     generalize hrecs gls1
+		     Proofview.V82.of_tactic (generalize hrecs) gls1
 	       end;
 	       match bro with
 		   None ->
-		     msg_warning (str "missing case");
-		     tacnext (mkMeta 1)
+                     warn_missing_case ();
+                     tacnext (mkMeta 1)
 		 | Some (sub_ids,tree) ->
 		     let br_args =
 		       List.filter
@@ -1305,7 +1332,11 @@ let understand_my_constr env sigma c concl =
   Pretyping.understand_tcc env sigma ~expected_type:(Pretyping.OfType concl) (frob rawc)
 
 let my_refine c gls =
-  let oc sigma = understand_my_constr (pf_env gls) sigma c (pf_concl gls) in
+  let oc = { run = begin fun sigma ->
+    let sigma = Sigma.to_evar_map sigma in
+    let (sigma, c) = understand_my_constr (pf_env gls) sigma c (pf_concl gls) in
+    Sigma.Unsafe.of_pair (c, sigma)
+  end } in
   Proofview.V82.of_tactic (Tactics.New.refine oc) gls
 
 (* end focus/claim *)
@@ -1341,7 +1372,7 @@ let end_tac et2 gls =
 		(default_justification (List.map mkVar clauses))
 	  | ET_Induction,EK_nodep ->
 	      tclTHENLIST
-		[generalize (pi.per_args@[pi.per_casee]);
+		[Proofview.V82.of_tactic (generalize (pi.per_args@[pi.per_casee]));
 		 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 ->
@@ -1353,7 +1384,7 @@ let end_tac et2 gls =
 		   (initial_instance_stack clauses) [pi.per_casee] 0 tree
 	  | ET_Induction,EK_dep tree ->
 	      let nargs = (List.length pi.per_args) in
-		tclTHEN (generalize (pi.per_args@[pi.per_casee]))
+		tclTHEN (Proofview.V82.of_tactic (generalize (pi.per_args@[pi.per_casee])))
 		  begin
 		    fun gls0 ->
 		      let fix_id =
@@ -1361,7 +1392,7 @@ let end_tac et2 gls =
 		      let c_id =
 			pf_get_new_id (Id.of_string "_main_arg") gls0 in
 			tclTHENLIST
-			  [fix (Some fix_id) (succ nargs);
+			  [Proofview.V82.of_tactic (fix (Some fix_id) (succ nargs));
 			   tclDO nargs (Proofview.V82.of_tactic introf);
 			   Proofview.V82.of_tactic (intro_mustbe_force c_id);
 			   execute_cases (Name fix_id) pi
diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4
index b62cfd6a..6c17dcc4 100644
--- a/plugins/decl_mode/g_decl_mode.ml4
+++ b/plugins/decl_mode/g_decl_mode.ml4
@@ -8,7 +8,8 @@
 
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
-open Util
+DECLARE PLUGIN "decl_mode_plugin"
+
 open Compat
 open Pp
 open Decl_expr
@@ -24,17 +25,14 @@ open Ppdecl_proof
 let pr_goal gs =
   let (g,sigma) = Goal.V82.nf_evar (Tacmach.project gs) (Evd.sig_it gs) 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 sigma,
-    Printer.pr_goal_concl_style_env env sigma (Goal.V82.concl sigma g)
-  in
-    preamb ++
-    str"  " ++ hv 0 (penv ++ fnl () ++
-		       str (Printer.emacs_str "")  ++
-		       str "============================" ++ fnl ()  ++
-		       thesis ++ str " " ++  pc) ++ fnl ()
+  let concl = Goal.V82.concl sigma g in
+  let goal =
+    Printer.pr_context_of env sigma ++ cut () ++
+      str "============================" ++ cut ()  ++
+      str "thesis :=" ++ cut () ++
+      Printer.pr_goal_concl_style_env env sigma concl in
+  str "     *** Declarative Mode ***" ++ fnl () ++ fnl () ++
+    str "  " ++ v 0 goal
 
 let pr_subgoals ?(pr_first=true) _ sigma _ _ _ gll =
   match gll with
@@ -60,7 +58,7 @@ let interp_proof_instr _ { Evd.it = gl ; sigma = sigma }=
 let vernac_decl_proof () = 
   let pf = Proof_global.give_me_the_proof () in
   if Proof.is_done pf then 
-    Errors.error "Nothing left to prove here."
+    CErrors.error "Nothing left to prove here."
   else
     begin
       Decl_proof_instr.go_to_proof_mode () ;
@@ -87,7 +85,7 @@ let vernac_proof_instr instr =
 
 (* Only declared at raw level, because only used in vernac commands. *)
 let wit_proof_instr : (raw_proof_instr, glob_proof_instr, proof_instr) Genarg.genarg_type =
-  Genarg.make0 None "proof_instr"
+  Genarg.make0 "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. *)
@@ -95,14 +93,14 @@ 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)
+  Pcoq.create_generic_entry Pcoq.utactic "proof_instr" (Genarg.rawwit wit_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 = function
   | { instr = Pescape |Pend B_proof } -> VtProofMode "Classic", VtNow
-  | _ -> VtProofStep false, VtLater
+  | _ -> Vernac_classifier.classify_as_proofstep
 
 (* We use the VERNAC EXTEND facility with a custom non-terminal
     to populate [proof_mode] with a new toplevel interpreter.
@@ -135,7 +133,7 @@ let _ =
 				       set = begin fun () ->
 					 (* We set the command non terminal to
 					     [proof_mode] (which we just defined). *)
-					 G_vernac.set_command_entry proof_mode ;
+					 Pcoq.set_command_entry proof_mode ;
 					 (* We substitute the goal printer, by the one we built
 					     for the proof mode. *)
 					 Printer.set_printer_pr { Printer.default_printer_pr with
@@ -147,7 +145,7 @@ let _ =
 				       reset = begin fun () ->
 					 (* We restore the command non terminal to
 					      [noedit_mode]. *)
-					 G_vernac.set_command_entry G_vernac.noedit_mode ;
+					 Pcoq.set_command_entry Pcoq.Vernac_.noedit_mode ;
 					 (* We restore the goal printer to default *)
 					 Printer.set_printer_pr Printer.default_printer_pr
 				       end
diff --git a/plugins/decl_mode/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml
index 4c71f041..59a0bb5a 100644
--- a/plugins/decl_mode/ppdecl_proof.ml
+++ b/plugins/decl_mode/ppdecl_proof.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Pp
 open Decl_expr
 open Names
diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml
index ce93c5a3..e39d17b5 100644
--- a/plugins/derive/derive.ml
+++ b/plugins/derive/derive.ml
@@ -6,6 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Context.Named.Declaration
+
 let map_const_entry_body (f:Term.constr->Term.constr) (x:Safe_typing.private_constants Entries.const_entry_body)
     : Safe_typing.private_constants Entries.const_entry_body =
   Future.chain ~pure:true x begin fun ((b,ctx),fx) ->
@@ -32,7 +34,7 @@ let start_deriving f suchthat lemma =
     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 env' = Environ.push_named (LocalDef (f, 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 _ ->
@@ -49,9 +51,9 @@ let start_deriving f suchthat lemma =
           [suchthat], respectively. *)
       let (opaque,f_def,lemma_def) =
         match com with
-        | Admitted _ -> Errors.error"Admitted isn't supported in Derive."
+        | Admitted _ -> CErrors.error"Admitted isn't supported in Derive."
         | Proved (_,Some _,_) ->
-            Errors.error"Cannot save a proof of Derive with an explicit name."
+            CErrors.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] ->
@@ -93,6 +95,7 @@ let start_deriving f suchthat lemma =
       ignore (Declare.declare_constant lemma lemma_def)
       in
 
+  let terminator = Proof_global.make_terminator terminator 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
diff --git a/plugins/derive/derive_plugin.mllib b/plugins/derive/derive_plugin.mlpack
index 5ee0fc6d..5ee0fc6d 100644
--- a/plugins/derive/derive_plugin.mllib
+++ b/plugins/derive/derive_plugin.mlpack
diff --git a/plugins/derive/g_derive.ml4 b/plugins/derive/g_derive.ml4
index 18570a68..d4dc7e0e 100644
--- a/plugins/derive/g_derive.ml4
+++ b/plugins/derive/g_derive.ml4
@@ -6,8 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Constrarg
+
 (*i camlp4deps: "grammar/grammar.cma"  i*)
 
+DECLARE PLUGIN "derive_plugin"
+
 let classify_derive_command _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]),VtLater)
 
 VERNAC COMMAND EXTEND Derive CLASSIFIED BY classify_derive_command
diff --git a/plugins/extraction/ExtrOcamlZBigInt.v b/plugins/extraction/ExtrOcamlZBigInt.v
index 9a1a4aa0..c9e8eac0 100644
--- a/plugins/extraction/ExtrOcamlZBigInt.v
+++ b/plugins/extraction/ExtrOcamlZBigInt.v
@@ -46,7 +46,7 @@ Extract Constant Pos.max => "Big.max".
 Extract Constant Pos.compare =>
  "fun x y -> Big.compare_case Eq Lt Gt x y".
 Extract Constant Pos.compare_cont =>
- "fun x y c -> Big.compare_case c Lt Gt x y".
+ "fun c x y -> Big.compare_case c Lt Gt x y".
 
 Extract Constant N.add => "Big.add".
 Extract Constant N.succ => "Big.succ".
diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml
index bb9e8e5f..3c5f6cb7 100644
--- a/plugins/extraction/common.ml
+++ b/plugins/extraction/common.ml
@@ -17,8 +17,8 @@ open Table
 open Miniml
 open Mlutil
 
-let string_of_id id =
-  let s = Names.Id.to_string id in
+let ascii_of_id id =
+  let s = Id.to_string id in
   for i = 0 to String.length s - 2 do
     if s.[i] == '_' && s.[i+1] == '_' then warning_id s
   done;
@@ -73,18 +73,19 @@ let fnl2 () = fnl () ++ fnl ()
 
 let space_if = function true -> str " " | false -> mt ()
 
-let is_digit = function
-  | '0'..'9' -> true
-  | _ -> false
+let begins_with s prefix =
+  let len = String.length prefix in
+  String.length s >= len && String.equal (String.sub s 0 len) prefix
 
 let begins_with_CoqXX s =
   let n = String.length s in
   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*)
-    else if is_digit s.[!i] then incr i
-    else raise Not_found
+    match s.[!i] with
+    | '_' -> i:=n (*Stop*)
+    | '0'..'9' -> incr i
+    | _ -> raise Not_found
   done; true
   with Not_found -> false
 
@@ -109,9 +110,9 @@ 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 (ascii_of_id id))
 let uppercase_id id =
-  let s = string_of_id id in
+  let s = ascii_of_id id in
   assert (not (String.is_empty s));
   if s.[0] == '_' then Id.of_string ("Coq_"^s)
   else Id.of_string (String.capitalize s)
@@ -331,13 +332,10 @@ let reset_renaming_tables flag =
    existing. *)
 
 let modular_rename k id =
-  let s = string_of_id id in
-  let prefix,is_ok =
-    if upperkind k then "Coq_",is_upper else "coq_",is_lower
+  let s = ascii_of_id id in
+  let prefix,is_ok = if upperkind k then "Coq_",is_upper else "coq_",is_lower
   in
-  if not (is_ok s) ||
-    (Id.Set.mem id (get_keywords ())) ||
-    (String.length s >= 4 && String.equal (String.sub s 0 4) prefix)
+  if not (is_ok s) || Id.Set.mem id (get_keywords ()) || begins_with s prefix
   then prefix ^ s
   else s
 
@@ -345,21 +343,20 @@ let modular_rename k id =
     with unique numbers *)
 
 let modfstlev_rename =
-  let add_prefixes,get_prefixes,_ = mktable_id true in
+  let add_index,get_index,_ = mktable_id true in
   fun l ->
-    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
-      add_prefixes id (nextcoq::coqset);
-      (string_of_id nextcoq)^"_"^(string_of_id id)
+      let n = get_index id in
+      add_index id (n+1);
+      let s = if n == 0 then "" else string_of_int (n-1) in
+      "Coq"^s^"_"^(ascii_of_id id)
     with Not_found ->
-      let s = string_of_id id in
+      let s = ascii_of_id id in
       if is_lower s || begins_with_CoqXX s then
-	(add_prefixes id [coqid]; "Coq_"^s)
+	(add_index id 1; "Coq_"^s)
       else
-	(add_prefixes id []; s)
+	(add_index id 0; s)
 
 (*s Creating renaming for a [module_path] : first, the real function ... *)
 
@@ -404,7 +401,7 @@ let ref_renaming_fun (k,r) =
     | [""] -> (* 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
+      Id.to_string id
     | _ -> modular_rename k idg
   in
   add_global_ids (Id.of_string s);
@@ -562,7 +559,7 @@ let pp_ocaml_extern k base rls = match rls with
 	(* Standard situation : object in an opened file *)
 	dottify rls'
 
-(* [pp_ocaml_gen] : choosing between [pp_ocaml_extern] or [pp_ocaml_extern] *)
+(* [pp_ocaml_gen] : choosing between [pp_ocaml_local] or [pp_ocaml_extern] *)
 
 let pp_ocaml_gen k mp rls olab =
   match common_prefix_from_list mp (get_visible_mps ()) with
@@ -579,8 +576,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 not (ModPath.equal (base_mp mp) (top_visible_mp ())) then s ^ "." else "" in
-    prf ^ str
+    if ModPath.equal (base_mp mp) (top_visible_mp ()) then str else s^"."^str
 
 (* Main name printing function for a reference *)
 
diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml
index 41a068ff..52f22ee6 100644
--- a/plugins/extraction/extract_env.ml
+++ b/plugins/extraction/extract_env.ml
@@ -13,13 +13,12 @@ open Names
 open Libnames
 open Globnames
 open Pp
-open Errors
+open CErrors
 open Util
 open Table
 open Extraction
 open Modutil
 open Common
-open Mod_subst
 
 (***************************************)
 (*S Part I: computing Coq environment. *)
@@ -542,7 +541,7 @@ let print_structure_to_file (fn,si,mo) dry struc =
     (if dry then None else si);
   (* Print the buffer content via Coq standard formatter (ok with coqide). *)
   if not (Int.equal (Buffer.length buf) 0) then begin
-    Pp.msg_notice (str (Buffer.contents buf));
+    Feedback.msg_notice (str (Buffer.contents buf));
     Buffer.reset buf
   end
 
@@ -584,8 +583,8 @@ let rec locate_ref = function
 	| None, Some r -> let refs,mps = locate_ref l in r::refs,mps
 	| Some mp, None -> let refs,mps = locate_ref l in refs,mp::mps
 	| Some mp, Some r ->
-	    warning_both_mod_and_cst q mp r;
-	    let refs,mps = locate_ref l in refs,mp::mps
+           warning_ambiguous_name (q,mp,r);
+           let refs,mps = locate_ref l in refs,mp::mps
 
 (*s Recursive extraction in the Coq toplevel. The vernacular command is
     \verb!Recursive Extraction! [qualid1] ... [qualidn]. Also used when
@@ -636,7 +635,7 @@ let simple_extraction r =
       in
       let ans = flag ++ print_one_decl struc (modpath_of_r r) d in
       reset ();
-      Pp.msg_notice ans
+      Feedback.msg_notice ans
   | _ -> assert false
 
 
diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml
index 10644da2..a980a43f 100644
--- a/plugins/extraction/extraction.ml
+++ b/plugins/extraction/extraction.ml
@@ -11,7 +11,6 @@ open Util
 open Names
 open Term
 open Vars
-open Context
 open Declarations
 open Declareops
 open Environ
@@ -26,6 +25,7 @@ open Globnames
 open Miniml
 open Table
 open Mlutil
+open Context.Rel.Declaration
 (*i*)
 
 exception I of inductive_kind
@@ -35,17 +35,18 @@ let current_fixpoints = ref ([] : constant list)
 
 let none = Evd.empty
 
+(* NB: In OCaml, [type_of] and [get_of] might raise
+   [SingletonInductiveBecomeProp]. This exception will be caught
+   in late wrappers around the exported functions of this file,
+   in order to display the location of the issue. *)
+
 let type_of env c =
-  try
-    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 polyprop = (lang() == Haskell) in
+  Retyping.get_type_of ~polyprop env none (strip_outer_cast c)
 
 let sort_of env c =
-  try
-    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
+  let polyprop = (lang() == Haskell) in
+  Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast c)
 
 (*S Generation of flags and signatures. *)
 
@@ -73,9 +74,9 @@ type flag = info * scheme
   Really important function. *)
 
 let rec flag_of_type env t : flag =
-  let t = whd_betadeltaiota env none t in
+  let t = whd_all env none t in
   match kind_of_term t with
-    | Prod (x,t,c) -> flag_of_type (push_rel (x,None,t) env) c
+    | Prod (x,t,c) -> flag_of_type (push_rel (LocalAssum (x,t)) env) c
     | Sort s when Sorts.is_prop s -> (Logic,TypeScheme)
     | Sort _ -> (Info,TypeScheme)
     | _ -> if (sort_of env t) == InProp then (Logic,Default) else (Info,Default)
@@ -101,14 +102,14 @@ let is_info_scheme env t = match flag_of_type env t with
 (*s [type_sign] gernerates a signature aimed at treating a type application. *)
 
 let rec type_sign env c =
-  match kind_of_term (whd_betadeltaiota env none c) with
+  match kind_of_term (whd_all env none c) with
     | Prod (n,t,d) ->
 	(if is_info_scheme env t then Keep else Kill Kprop)
 	:: (type_sign (push_rel_assum (n,t) env) d)
     | _ -> []
 
 let rec type_scheme_nb_args env c =
-  match kind_of_term (whd_betadeltaiota env none c) with
+  match kind_of_term (whd_all env none c) with
     | Prod (n,t,d) ->
 	let n = type_scheme_nb_args (push_rel_assum (n,t) env) d in
 	if is_info_scheme env t then n+1 else n
@@ -134,7 +135,7 @@ let make_typvar n vl =
   next_ident_away id' vl
 
 let rec type_sign_vl env c =
-  match kind_of_term (whd_betadeltaiota env none c) with
+  match kind_of_term (whd_all 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 Kprop::s, vl
@@ -142,7 +143,7 @@ let rec type_sign_vl env c =
     | _ -> [],[]
 
 let rec nb_default_params env c =
-  match kind_of_term (whd_betadeltaiota env none c) with
+  match kind_of_term (whd_all env none c) with
     | Prod (n,t,d) ->
 	let n = nb_default_params (push_rel_assum (n,t) env) d in
 	if is_default env t then n+1 else n
@@ -248,7 +249,7 @@ let rec extract_type env db j c args =
     | _ when sort_of env (applist (c, args)) == InProp -> Tdummy Kprop
     | Rel n ->
 	(match lookup_rel n env with
-           | (_,Some t,_) -> extract_type env db j (lift n t) args
+           | LocalDef (_,t,_) -> extract_type env db j (lift n t) args
 	   | _ ->
 	       (* Asks [db] a translation for [n]. *)
 	       if n > List.length db then Tunknown
@@ -285,7 +286,7 @@ let rec extract_type env db j c args =
     | 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
+    | Case _ | Fix _ | CoFix _ | Proj _ -> Tunknown
     | _ -> assert false
 
 (*s Auxiliary function dealing with type application.
@@ -328,11 +329,22 @@ and extract_type_scheme env db c p =
 
 (*S Extraction of an inductive type. *)
 
+(* First, a version with cache *)
+
 and extract_ind env kn = (* kn is supposed to be in long form *)
   let mib = Environ.lookup_mind kn env in
   match lookup_ind kn mib with
   | Some ml_ind -> ml_ind
   | None ->
+     try
+       extract_really_ind env kn mib
+     with SingletonInductiveBecomesProp id ->
+       (* TODO : which inductive is concerned in the block ? *)
+       error_singleton_become_prop id (Some (IndRef (kn,0)))
+
+(* Then the real function *)
+
+and extract_really_ind env kn mib =
     (* First, if this inductive is aliased via a Module,
        we process the original inductive if possible.
        When at toplevel of the monolithic case, we cannot do much
@@ -359,8 +371,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
     let packets =
       Array.mapi
 	(fun i mip ->
-	   let (ind,u), ctx = 
-	     Universes.fresh_inductive_instance env (kn,i) in
+	   let (_,u),_ = 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
@@ -477,7 +488,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 *)
 
 and extract_type_cons env db dbmap c i =
-  match kind_of_term (whd_betadeltaiota env none c) with
+  match kind_of_term (whd_all env none c) with
     | Prod (n,t,d) ->
 	let env' = push_rel_assum (n,t) env in
 	let db' = (try Int.Map.find i dbmap with Not_found -> 0) :: db in
@@ -561,7 +572,7 @@ let rec extract_term env mle mlt c args =
 	       put_magic_if magic (MLlam (id, d')))
     | LetIn (n, c1, t1, c2) ->
 	let id = id_of_name n in
-	let env' = push_rel (Name id, Some c1, t1) env in
+	let env' = push_rel (LocalDef (Name id, c1, t1)) env in
 	(* We directly push the args inside the [LetIn].
            TODO: the opt_let_app flag is supposed to prevent that *)
 	let args' = List.map (lift 1) args in
@@ -579,10 +590,10 @@ 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,u) ->
-	extract_cst_app env mle mlt kn u args
-    | Construct (cp,u) ->
-	extract_cons_app env mle mlt cp u args
+    | Const (kn,_) ->
+	extract_cst_app env mle mlt kn args
+    | Construct (cp,_) ->
+	extract_cons_app env mle mlt cp args
     | Proj (p, c) ->
         let term = Retyping.expand_projection env (Evd.from_env env) p c [] in
 	  extract_term env mle mlt term args
@@ -633,7 +644,7 @@ and make_mlargs env e s args typs =
 
 (*s Extraction of a constant applied to arguments. *)
 
-and extract_cst_app env mle mlt kn u args =
+and extract_cst_app env mle mlt kn 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
@@ -672,7 +683,7 @@ and extract_cst_app env mle mlt kn u args =
 	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
+      with e when CErrors.noncritical e -> mla
   in
   (* For strict languages, purely logical signatures lead to a dummy lam
      (except when [Kill Ktype] everywhere). So a [MLdummy] is left
@@ -706,7 +717,7 @@ and extract_cst_app env mle mlt kn u 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) u args =
+and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) 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
@@ -836,7 +847,7 @@ and extract_fix env mle i (fi,ti,ci as recd) mlt =
 
 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 = List.map (fun (LocalAssum (id,c) | LocalDef (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. *)
@@ -934,11 +945,13 @@ 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
-      let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in
-      terms.(i) <- e;
-      types.(i) <- t;
-    end
+    if sort_of env ti.(i) != InProp then
+      try
+        let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in
+        terms.(i) <- e;
+        types.(i) <- t;
+      with SingletonInductiveBecomesProp id ->
+        error_singleton_become_prop id (Some (ConstRef vkn.(i)))
   done;
   current_fixpoints := [];
   Dfix (Array.map (fun kn -> ConstRef kn) vkn, terms, types)
@@ -968,13 +981,17 @@ let extract_constant env kn cb =
     let e,t = extract_std_constant env kn c typ in
     Dterm (r,e,t)
   in
-  match flag_of_type env typ with
+  try
+    match flag_of_type env typ with
     | (Logic,TypeScheme) -> warn_log (); Dtype (r, [], Tdummy Ktype)
     | (Logic,Default) -> warn_log (); Dterm (r, MLdummy Kprop, Tdummy Kprop)
     | (Info,TypeScheme) ->
         (match cb.const_body with
 	  | Undef _ -> warn_info (); mk_typ_ax ()
-	  | Def c -> mk_typ (Mod_subst.force_constr c)
+	  | Def c ->
+	     (match cb.const_proj with
+	      | None -> mk_typ (Mod_subst.force_constr c)
+	      | Some pb -> mk_typ pb.proj_body)
 	  | OpaqueDef c ->
 	    add_opaque r;
 	    if access_opaque () then
@@ -983,17 +1000,23 @@ let extract_constant env kn cb =
     | (Info,Default) ->
         (match cb.const_body with
 	  | Undef _ -> warn_info (); mk_ax ()
-	  | Def c -> mk_def (Mod_subst.force_constr c)
+	  | Def c ->
+	     (match cb.const_proj with
+	      | None -> mk_def (Mod_subst.force_constr c)
+	      | Some pb -> mk_def pb.proj_body)
 	  | OpaqueDef c ->
 	    add_opaque r;
 	    if access_opaque () then
               mk_def (Opaqueproof.force_proof (Environ.opaque_tables env) c)
             else mk_ax ())
+  with SingletonInductiveBecomesProp id ->
+    error_singleton_become_prop id (Some (ConstRef kn))
 
 let extract_constant_spec env kn cb =
   let r = ConstRef kn in
   let typ = Typeops.type_of_constant_type env cb.const_type in
-  match flag_of_type env typ with
+  try
+    match flag_of_type env typ with
     | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype))
     | (Logic, Default) -> Sval (r, Tdummy Kprop)
     | (Info, TypeScheme) ->
@@ -1008,26 +1031,34 @@ let extract_constant_spec env kn cb =
     | (Info, Default) ->
 	let t = snd (record_constant_type env kn (Some typ)) in
 	Sval (r, type_expunge env t)
+  with SingletonInductiveBecomesProp id ->
+    error_singleton_become_prop id (Some (ConstRef kn))
 
 let extract_with_type env c =
-  let typ = type_of env c in
-  match flag_of_type env typ with
+  try
+    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 t = extract_type_scheme env db c (List.length s) in
 	Some (vl, t)
     | _ -> None
+  with SingletonInductiveBecomesProp id ->
+    error_singleton_become_prop id None
 
 let extract_constr env c =
   reset_meta_count ();
-  let typ = type_of env c in
-  match flag_of_type env typ with
+  try
+    let typ = type_of env c in
+    match flag_of_type env typ with
     | (_,TypeScheme) -> MLdummy Ktype, Tdummy Ktype
     | (Logic,_) -> MLdummy Kprop, Tdummy Kprop
     | (Info,Default) ->
-      let mlt = extract_type env [] 1 typ [] in
-      extract_term env Mlenv.empty mlt c [], mlt
+       let mlt = extract_type env [] 1 typ [] in
+       extract_term env Mlenv.empty mlt c [], mlt
+  with SingletonInductiveBecomesProp id ->
+    error_singleton_become_prop id None
 
 let extract_inductive env kn =
   let ind = extract_ind env kn in
diff --git a/plugins/extraction/extraction_plugin.mllib b/plugins/extraction/extraction_plugin.mlpack
index ad321243..9184f650 100644
--- a/plugins/extraction/extraction_plugin.mllib
+++ b/plugins/extraction/extraction_plugin.mlpack
@@ -9,4 +9,3 @@ Scheme
 Json
 Extract_env
 G_extraction
-Extraction_plugin_mod
diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4
index aec95868..19fda4ae 100644
--- a/plugins/extraction/g_extraction.ml4
+++ b/plugins/extraction/g_extraction.ml4
@@ -8,9 +8,14 @@
 
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
+DECLARE PLUGIN "extraction_plugin"
+
 (* ML names *)
 
 open Genarg
+open Stdarg
+open Constrarg
+open Pcoq.Prim
 open Pp
 open Names
 open Nameops
@@ -31,7 +36,6 @@ let pr_int_or_id _ _ _ = function
   | ArgId id -> pr_id id
 
 ARGUMENT EXTEND int_or_id
-  TYPED AS int_or_id
   PRINTED BY pr_int_or_id
 | [ preident(id) ] -> [ ArgId (Id.of_string id) ]
 | [ integer(i) ] -> [ ArgInt i ]
@@ -99,7 +103,7 @@ END
 
 VERNAC COMMAND EXTEND PrintExtractionInline CLASSIFIED AS QUERY
 | [ "Print" "Extraction" "Inline" ]
-  -> [ msg_info (print_extraction_inline ()) ]
+  -> [Feedback. msg_info (print_extraction_inline ()) ]
 END
 
 VERNAC COMMAND EXTEND ResetExtractionInline CLASSIFIED AS SIDEFF
@@ -121,7 +125,7 @@ END
 
 VERNAC COMMAND EXTEND PrintExtractionBlacklist CLASSIFIED AS QUERY
 | [ "Print" "Extraction" "Blacklist" ]
-  -> [ msg_info (print_extraction_blacklist ()) ]
+  -> [ Feedback.msg_info (print_extraction_blacklist ()) ]
 END
 
 VERNAC COMMAND EXTEND ResetExtractionBlacklist CLASSIFIED AS SIDEFF
diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml
index 22519e34..0692c88c 100644
--- a/plugins/extraction/haskell.ml
+++ b/plugins/extraction/haskell.ml
@@ -9,7 +9,7 @@
 (*s Production of Haskell syntax. *)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
@@ -346,7 +346,7 @@ let pp_decl = function
 	  in
 	  if void then mt ()
 	  else
-	    names.(i) ++ str " :: " ++ pp_type false [] typs.(i) ++ fnl () ++
+	    hov 2 (names.(i) ++ str " :: " ++ pp_type false [] typs.(i)) ++ fnl () ++
 	    (if is_custom r then
 		(names.(i) ++ str " = " ++ str (find_custom r))
 	     else
@@ -357,7 +357,7 @@ let pp_decl = function
       if is_inline_custom r then mt ()
       else
 	let e = pp_global Term r in
-	e ++ str " :: " ++ pp_type false [] t ++ fnl () ++
+	hov 2 (e ++ str " :: " ++ pp_type false [] t) ++ fnl () ++
 	  if is_custom r then
 	    hov 0 (e ++ str " = " ++ str (find_custom r) ++ fnl2 ())
 	  else
diff --git a/plugins/extraction/json.ml b/plugins/extraction/json.ml
index df79c585..e43c47d0 100644
--- a/plugins/extraction/json.ml
+++ b/plugins/extraction/json.ml
@@ -1,8 +1,6 @@
 open Pp
-open Errors
 open Util
 open Names
-open Nameops
 open Globnames
 open Table
 open Miniml
@@ -18,9 +16,6 @@ let json_int i =
 let json_bool b =
   if b then str "true" else str "false"
 
-let json_null =
-  str "null"
-
 let json_global typ ref =
   json_str (Common.pp_global typ ref)
 
@@ -147,7 +142,8 @@ let rec json_expr env = function
           ("what", json_str "fix:item");
           ("name", json_id fi);
           ("body", json_function env' ti)
-        ]) (Array.map2 (fun a b -> a,b) ids' defs)))
+        ]) (Array.map2 (fun a b -> a,b) ids' defs)));
+      ("for", json_int i);
     ]
   | MLexn s -> json_dict [
       ("what", json_str "expr:exception");
diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml
index b5e8b480..60fe8e76 100644
--- a/plugins/extraction/modutil.ml
+++ b/plugins/extraction/modutil.ml
@@ -8,7 +8,7 @@
 
 open Names
 open Globnames
-open Errors
+open CErrors
 open Util
 open Miniml
 open Table
@@ -310,7 +310,7 @@ let base_r = function
 let reset_needed, add_needed, add_needed_mp, found_needed, is_needed =
   let needed = ref Refset'.empty
   and needed_mps = ref MPset.empty in
-  ((fun l -> needed := Refset'.empty; needed_mps := MPset.empty),
+  ((fun () -> needed := Refset'.empty; needed_mps := MPset.empty),
    (fun r -> needed := Refset'.add (base_r r) !needed),
    (fun mp -> needed_mps := MPset.add mp !needed_mps),
    (fun r -> needed := Refset'.remove (base_r r) !needed),
@@ -380,14 +380,6 @@ let rec depcheck_struct = function
       let lse' = depcheck_se lse in
       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
-
 exception RemainingImplicit of kill_reason
 
 let check_for_remaining_implicits struc =
diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml
index 3cb3810c..1c29a9bc 100644
--- a/plugins/extraction/ocaml.ml
+++ b/plugins/extraction/ocaml.ml
@@ -9,7 +9,7 @@
 (*s Production of Ocaml syntax. *)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
@@ -203,7 +203,7 @@ let rec pp_expr par env args =
 	   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))
+	 with e when CErrors.noncritical e -> apply (pp_global Term r))
     | MLfix (i,ids,defs) ->
 	let ids',env' = push_vars (List.rev (Array.to_list ids)) env in
 	pp_fix par env' i (Array.of_list (List.rev ids'),defs) args
diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml
index 7b0f14df..a6309e61 100644
--- a/plugins/extraction/scheme.ml
+++ b/plugins/extraction/scheme.ml
@@ -9,7 +9,7 @@
 (*s Production of Scheme syntax. *)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Miniml
diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml
index d7842e12..ff66d915 100644
--- a/plugins/extraction/table.ml
+++ b/plugins/extraction/table.ml
@@ -15,7 +15,7 @@ open Libobject
 open Goptions
 open Libnames
 open Globnames
-open Errors
+open CErrors
 open Util
 open Pp
 open Miniml
@@ -295,81 +295,94 @@ let pr_long_global ref = pr_path (Nametab.path_of_global ref)
 
 let err s = errorlabstrm "Extraction" s
 
+let warn_extraction_axiom_to_realize =
+  CWarnings.create ~name:"extraction-axiom-to-realize" ~category:"extraction"
+         (fun axioms ->
+          let s = if Int.equal (List.length axioms) 1 then "axiom" else "axioms" in
+          strbrk ("The following "^s^" must be realized in the extracted code:")
+                   ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global axioms)
+                   ++ str "." ++ fnl ())
+
+let warn_extraction_logical_axiom =
+  CWarnings.create ~name:"extraction-logical-axiom" ~category:"extraction"
+         (fun axioms ->
+          let s =
+            if Int.equal (List.length axioms) 1 then "axiom was" else "axioms were"
+          in
+          (strbrk ("The following logical "^s^" encountered:") ++
+             hov 1 (spc () ++ prlist_with_sep spc safe_pr_global axioms ++ str ".\n")
+           ++ strbrk "Having invalid logical axiom in the environment when extracting"
+           ++ spc () ++ strbrk "may lead to incorrect or non-terminating ML terms." ++
+             fnl ()))
+
 let warning_axioms () =
   let info_axioms = Refset'.elements !info_axioms in
-  if List.is_empty info_axioms then ()
-  else begin
-    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;
+  if not (List.is_empty info_axioms) then
+    warn_extraction_axiom_to_realize info_axioms;
   let log_axioms = Refset'.elements !log_axioms in
-  if List.is_empty log_axioms then ()
-  else begin
-    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:") ++
-       hov 1
-         (spc () ++ prlist_with_sep spc safe_pr_global log_axioms ++ str ".\n")
-       ++
-       str "Having invalid logical axiom in the environment when extracting" ++
-       spc () ++ str "may lead to incorrect or non-terminating ML terms." ++
-       fnl ())
-  end
+  if not (List.is_empty log_axioms) then
+    warn_extraction_logical_axiom log_axioms
+
+let warn_extraction_opaque_accessed =
+  CWarnings.create ~name:"extraction-opaque-accessed" ~category:"extraction"
+    (fun lst -> strbrk "The extraction is currently set to bypass opacity, " ++
+                  strbrk "the following opaque constant bodies have been accessed :" ++
+                  lst ++ str "." ++ fnl ())
+
+let warn_extraction_opaque_as_axiom =
+  CWarnings.create ~name:"extraction-opaque-as-axiom" ~category:"extraction"
+    (fun lst -> strbrk "The extraction now honors the opacity constraints by default, " ++
+	 strbrk "the following opaque constants have been extracted as axioms :" ++
+	 lst ++ str "." ++ fnl () ++
+	 strbrk "If necessary, use \"Set Extraction AccessOpaque\" to change this."
+	 ++ fnl ())
 
 let warning_opaques accessed =
   let opaques = Refset'.elements !opaques in
-  if List.is_empty opaques then ()
-  else
+  if not (List.is_empty opaques) then
     let lst = hov 1 (spc () ++ prlist_with_sep spc safe_pr_global opaques) in
-    if accessed then
-      msg_warning
-	(str "The extraction is currently set to bypass opacity,\n" ++
-	 str "the following opaque constant bodies have been accessed :" ++
-	 lst ++ str "." ++ fnl ())
-    else
-      msg_warning
-	(str "The extraction now honors the opacity constraints by default,\n" ++
-	 str "the following opaque constants have been extracted as axioms :" ++
-	 lst ++ str "." ++ fnl () ++
-	 str "If necessary, use \"Set Extraction AccessOpaque\" to change this."
-	 ++ fnl ())
-
-let warning_both_mod_and_cst q mp r =
- msg_warning
-   (str "The name " ++ pr_qualid q ++ str " is ambiguous, " ++
-    str "do you mean module " ++
-    pr_long_mp mp ++
-    str " or object " ++
-    pr_long_global r ++ str " ?" ++ fnl () ++
-    str "First choice is assumed, for the second one please use " ++
-    str "fully qualified name." ++ fnl ())
+    if accessed then warn_extraction_opaque_accessed lst
+    else warn_extraction_opaque_as_axiom lst
+
+let warning_ambiguous_name =
+  CWarnings.create ~name:"extraction-ambiguous-name" ~category:"extraction"
+    (fun (q,mp,r) -> strbrk "The name " ++ pr_qualid q ++ strbrk " is ambiguous, " ++
+                       strbrk "do you mean module " ++
+                       pr_long_mp mp ++
+                       strbrk " or object " ++
+                       pr_long_global r ++ str " ?" ++ fnl () ++
+                       strbrk "First choice is assumed, for the second one please use " ++
+                       strbrk "fully qualified name." ++ fnl ())
 
 let error_axiom_scheme r i =
   err (str "The type scheme axiom " ++ spc () ++
        safe_pr_global r ++ spc () ++ str "needs " ++ int i ++
        str " type variable(s).")
 
+let warn_extraction_inside_module =
+  CWarnings.create ~name:"extraction-inside-module" ~category:"extraction"
+      (fun () -> strbrk "Extraction inside an opened module is experimental." ++
+       strbrk "In case of problem, close it first.")
+
+
 let check_inside_module () =
   if Lib.is_modtype () then
     err (str "You can't do that within a Module Type." ++ fnl () ++
 	 str "Close it and try again.")
   else if Lib.is_module () then
-    msg_warning
-      (str "Extraction inside an opened module is experimental.\n" ++
-       str "In case of problem, close it first.\n")
+    warn_extraction_inside_module ()
 
 let check_inside_section () =
   if Lib.sections_are_opened () then
     err (str "You can't do that within a section." ++ fnl () ++
 	 str "Close it and try again.")
 
-let warning_id s =
-  msg_warning (str ("The identifier "^s^
-		    " contains __ which is reserved for the extraction"))
+let warn_extraction_reserved_identifier =
+  CWarnings.create ~name:"extraction-reserved-identifier" ~category:"extraction"
+    (fun s -> strbrk ("The identifier "^s^
+                " contains __ which is reserved for the extraction"))
+
+let warning_id s = warn_extraction_reserved_identifier s
 
 let error_constant r =
   err (safe_pr_global r ++ str " is not a constant.")
@@ -391,9 +404,15 @@ let error_no_module_expr mp =
        ++ str "some Declare Module outside any Module Type.\n"
        ++ str "This situation is currently unsupported by the extraction.")
 
-let error_singleton_become_prop id =
+let error_singleton_become_prop id og =
+  let loc =
+    match og with
+    | Some g -> fnl () ++ str "in " ++ safe_pr_global g ++
+                str " (or in its mutual block)"
+    | None -> mt ()
+  in
   err (str "The informative inductive type " ++ pr_id id ++
-       str " has a Prop instance.\n" ++
+       str " has a Prop instance" ++ loc ++ str "." ++ fnl () ++
        str "This happens when a sort-polymorphic singleton inductive type\n" ++
        str "has logical parameters, such as (I,I) : (True * True) : Prop.\n" ++
        str "The Ocaml extraction cannot handle this situation yet.\n" ++
@@ -422,7 +441,7 @@ let error_MPfile_as_mod mp b =
 let argnames_of_global r =
   let typ = Global.type_of_global_unsafe r in
   let rels,_ =
-    decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in
+    decompose_prod (Reduction.whd_all (Global.env ()) typ) in
   List.rev_map fst rels
 
 let msg_of_implicit = function
@@ -441,25 +460,28 @@ let error_remaining_implicit k =
        str "You might also try Unset Extraction SafeImplicits to force" ++
        fnl() ++ str "the extraction of unsafe code and review it manually.")
 
+let warn_extraction_remaining_implicit =
+  CWarnings.create ~name:"extraction-remaining-implicit" ~category:"extraction"
+    (fun s -> strbrk ("At least an implicit occurs after extraction : "^s^".") ++ fnl () ++
+     strbrk "Extraction SafeImplicits is unset, extracting nonetheless,"
+     ++ strbrk "but this code is potentially unsafe, please review it manually.")
+
 let warning_remaining_implicit k =
   let s = msg_of_implicit k in
-  msg_warning
-    (str ("At least an implicit occurs after extraction : "^s^".") ++ fnl () ++
-     str "Extraction SafeImplicits is unset, extracting nonetheless," ++ fnl ()
-     ++ str "but this code is potentially unsafe, please review it manually.")
+  warn_extraction_remaining_implicit s
 
 let check_loaded_modfile mp = match base_mp mp with
   | MPfile dp ->
       if not (Library.library_is_loaded dp) then begin
 	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.")))
+	      err (str "Please load library " ++ pr_dirpath dp ++ str " first.")
 	  | _ -> ()
       end
   | _ -> ()
 
 let info_file f =
-  Flags.if_verbose msg_info
+  Flags.if_verbose Feedback.msg_info
     (str ("The file "^f^" has been created by extraction."))
 
 
@@ -858,7 +880,7 @@ let extract_constant_inline inline r ids s =
     | ConstRef kn ->
 	let env = Global.env () in
 	let typ = Global.type_of_global_unsafe (ConstRef kn) in
-	let typ = Reduction.whd_betadeltaiota env typ in
+	let typ = Reduction.whd_all env typ in
 	if Reduction.is_arity env typ
 	  then begin
 	    let nargs = Hook.get use_type_scheme_nb_args env typ in
diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli
index 2b163610..15a08756 100644
--- a/plugins/extraction/table.mli
+++ b/plugins/extraction/table.mli
@@ -21,8 +21,7 @@ val safe_basename_of_global : global_reference -> Id.t
 
 val warning_axioms : unit -> unit
 val warning_opaques : bool -> unit
-val warning_both_mod_and_cst :
- qualid -> module_path -> global_reference -> unit
+val warning_ambiguous_name : ?loc:Loc.t -> qualid * module_path * global_reference -> unit
 val warning_id : string -> unit
 val error_axiom_scheme : global_reference -> int -> 'a
 val error_constant : global_reference -> 'a
@@ -30,7 +29,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 : Id.t -> 'a
+val error_singleton_become_prop : Id.t -> global_reference option -> 'a
 val error_unknown_module : qualid -> 'a
 val error_scheme : unit -> 'a
 val error_not_visible : global_reference -> 'a
diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml
index ae2d059f..58744b57 100644
--- a/plugins/firstorder/formula.ml
+++ b/plugins/firstorder/formula.ml
@@ -15,10 +15,11 @@ open Tacmach
 open Util
 open Declarations
 open Globnames
+open Context.Rel.Declaration
 
 let qflag=ref true
 
-let red_flags=ref Closure.betaiotazeta
+let red_flags=ref CClosure.betaiotazeta
 
 let (=?) f g i1 i2 j1 j2=
   let c=f i1 i2 in
@@ -58,12 +59,12 @@ let ind_hyps nevar ind largs gls=
     Array.map myhyps types
 
 let special_nf gl=
-  let infos=Closure.create_clos_infos !red_flags (pf_env gl) in
-    (fun t -> Closure.norm_val infos (Closure.inject t))
+  let infos=CClosure.create_clos_infos !red_flags (pf_env gl) in
+    (fun t -> CClosure.norm_val infos (CClosure.inject t))
 
 let special_whd gl=
-  let infos=Closure.create_clos_infos !red_flags (pf_env gl) in
-    (fun t -> Closure.whd_val infos (Closure.inject t))
+  let infos=CClosure.create_clos_infos !red_flags (pf_env gl) in
+    (fun t -> CClosure.whd_val infos (CClosure.inject t))
 
 type kind_of_formula=
     Arrow of constr*constr
@@ -139,8 +140,8 @@ let build_atoms gl metagen side cciterm =
 		  negative:= unsigned :: !negative
 	    end;
 	  let v = ind_hyps 0 i l gl in
-	  let g i _ (_,_,t) =
-	    build_rec env polarity (lift i t) in
+	  let g i _ decl =
+	    build_rec env polarity (lift i (get_type decl)) in
 	  let f l =
 	    List.fold_left_i g (1-(List.length l)) () l in
 	    if polarity && (* we have a constant constructor *)
@@ -150,8 +151,8 @@ let build_atoms gl metagen side cciterm =
       | Exists(i,l)->
 	  let var=mkMeta (metagen true) in
 	  let v =(ind_hyps 1 i l gl).(0) in
-	  let g i _ (_,_,t) =
-	    build_rec (var::env) polarity (lift i t) in
+	  let g i _ decl =
+	    build_rec (var::env) polarity (lift i (get_type decl)) in
 	    List.fold_left_i g (2-(List.length l)) () v
       | Forall(_,b)->
 	  let var=mkMeta (metagen true) in
@@ -224,7 +225,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 = get_type (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 39d99d2e..5db8ff59 100644
--- a/plugins/firstorder/formula.mli
+++ b/plugins/firstorder/formula.mli
@@ -7,12 +7,11 @@
 (************************************************************************)
 
 open Term
-open Context
 open Globnames
 
 val qflag : bool ref
 
-val red_flags: Closure.RedFlags.reds ref
+val red_flags: CClosure.RedFlags.reds ref
 
 val (=?) : ('a -> 'a -> int) -> ('b -> 'b -> int) ->
   'a -> 'a -> 'b -> 'b -> int
@@ -27,7 +26,7 @@ type counter = bool -> metavariable
 val construct_nhyps : pinductive -> Proof_type.goal Tacmach.sigma -> int array
 
 val ind_hyps : int -> pinductive -> constr list ->
-  Proof_type.goal Tacmach.sigma -> rel_context array
+  Proof_type.goal Tacmach.sigma -> Context.Rel.t array
 
 type atoms = {positive:constr list;negative:constr list}
 
diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4
index 04152688..43fac8ad 100644
--- a/plugins/firstorder/g_ground.ml4
+++ b/plugins/firstorder/g_ground.ml4
@@ -15,6 +15,9 @@ open Goptions
 open Tacticals
 open Tacinterp
 open Libnames
+open Constrarg
+open Stdarg
+open Pcoq.Prim
 
 DECLARE PLUGIN "ground_plugin"
 
@@ -52,8 +55,15 @@ let _=
   in
     declare_int_option gdopt
 
+let default_intuition_tac =
+  let tac _ _ = Auto.h_auto None [] None in
+  let name = { Tacexpr.mltac_plugin = "ground_plugin"; mltac_tactic = "auto_with"; } in
+  let entry = { Tacexpr.mltac_name = name; mltac_index = 0 } in
+  Tacenv.register_ml_tactic name [| tac |];
+  Tacexpr.TacML (Loc.ghost, entry, [])
+
 let (set_default_solver, default_solver, print_default_solver) = 
-  Tactic_option.declare_tactic_option ~default:(<:tactic<auto with *>>) "Firstorder default solver"
+  Tactic_option.declare_tactic_option ~default:default_intuition_tac "Firstorder default solver"
 
 VERNAC COMMAND EXTEND Firstorder_Set_Solver CLASSIFIED AS SIDEFF
 | [ "Set" "Firstorder" "Solver" tactic(t) ] -> [
@@ -64,7 +74,7 @@ END
 
 VERNAC COMMAND EXTEND Firstorder_Print_Solver CLASSIFIED AS QUERY
 | [ "Print" "Firstorder" "Solver" ] -> [
-    Pp.msg_info
+    Feedback.msg_info
       (Pp.(++) (Pp.str"Firstorder solver tactic is ") (print_default_solver ())) ]
 END
 
@@ -106,11 +116,17 @@ open Pp
 open Genarg
 open Ppconstr
 open Printer
-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
+let pr_firstorder_using_raw _ _ _ = Pptactic.pr_auto_using pr_reference
+let pr_firstorder_using_glob _ _ _ = Pptactic.pr_auto_using (pr_or_var (fun x -> pr_global (snd x)))
+let pr_firstorder_using_typed _ _ _ = Pptactic.pr_auto_using pr_global
+
+let warn_deprecated_syntax =
+  CWarnings.create ~name:"firstorder-deprecated-syntax" ~category:"deprecated"
+    (fun () -> Pp.strbrk "Deprecated syntax; use \",\" as separator")
+
 
 ARGUMENT EXTEND firstorder_using
+  TYPED AS reference_list
   PRINTED BY pr_firstorder_using_typed
   RAW_TYPED AS reference_list
   RAW_PRINTED BY pr_firstorder_using_raw
@@ -119,8 +135,7 @@ ARGUMENT EXTEND firstorder_using
 | [ "using" reference(a) ] -> [ [a] ]
 | [ "using" reference(a) "," ne_reference_list_sep(l,",") ] -> [ a::l ]
 | [ "using" reference(a) reference(b) reference_list(l) ] -> [
-    Flags.if_verbose
-      Pp.msg_warning (Pp.str "Deprecated syntax; use \",\" as separator");
+    warn_deprecated_syntax ();
     a::b::l
   ]
 | [ ] -> [ [] ]
@@ -128,20 +143,22 @@ END
 
 TACTIC EXTEND firstorder
     [ "firstorder" tactic_opt(t) firstorder_using(l) ] ->
-      [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) l []) ]
+      [ Proofview.V82.tactic (gen_ground_tac true (Option.map (tactic_of_value ist) t) l []) ]
 |   [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] ->
-      [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) [] l) ]
+      [ Proofview.V82.tactic (gen_ground_tac true (Option.map (tactic_of_value ist) t) [] l) ]
 |   [ "firstorder" tactic_opt(t) firstorder_using(l)
        "with" ne_preident_list(l') ] ->
-      [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) l l') ]
+      [ Proofview.V82.tactic (gen_ground_tac true (Option.map (tactic_of_value ist) t) l l') ]
 END
 
 TACTIC EXTEND gintuition
   [ "gintuition" tactic_opt(t) ] ->
-     [ Proofview.V82.tactic (gen_ground_tac false (Option.map eval_tactic t) [] []) ]
+     [ Proofview.V82.tactic (gen_ground_tac false (Option.map (tactic_of_value ist) t) [] []) ]
 END
 
 open Proofview.Notations
+open Cc_plugin
+open Decl_mode_plugin
 
 let default_declarative_automation =
   Proofview.tclUNIT () >>= fun () -> (* delay for [congruence_depth] *)
diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml
index 3b9f67f6..628af4e7 100644
--- a/plugins/firstorder/ground.ml
+++ b/plugins/firstorder/ground.ml
@@ -24,15 +24,15 @@ let update_flags ()=
   in
     List.iter f (Classops.coercions ());
     red_flags:=
-    Closure.RedFlags.red_add_transparent
-      Closure.betaiotazeta
+    CClosure.RedFlags.red_add_transparent
+      CClosure.betaiotazeta
       (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.msg_debug (Printer.pr_goal gl);
+    then Feedback.msg_debug (Printer.pr_goal gl);
     tclORELSE (axiom_tac seq.gl seq)
       begin
 	try
diff --git a/plugins/firstorder/ground_plugin.mllib b/plugins/firstorder/ground_plugin.mlpack
index 447a1fb5..65fb2e9a 100644
--- a/plugins/firstorder/ground_plugin.mllib
+++ b/plugins/firstorder/ground_plugin.mlpack
@@ -5,4 +5,3 @@ Rules
 Instances
 Ground
 G_ground
-Ground_plugin_mod
diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml
index a717cc91..eebd974e 100644
--- a/plugins/firstorder/instances.ml
+++ b/plugins/firstorder/instances.ml
@@ -8,11 +8,10 @@
 
 open Unify
 open Rules
-open Errors
+open CErrors
 open Util
 open Term
 open Vars
-open Glob_term
 open Tacmach
 open Tactics
 open Tacticals
@@ -22,6 +21,8 @@ open Formula
 open Sequent
 open Names
 open Misctypes
+open Sigma.Notations
+open Context.Rel.Declaration
 
 let compare_instance inst1 inst2=
 	match inst1,inst2 with
@@ -96,8 +97,6 @@ let rec collect_quantified seq=
 
 (* open instances processor *)
 
-let dummy_constr=mkMeta (-1)
-
 let dummy_bvid=Id.of_string "x"
 
 let mk_open_instance id idc gl m t=
@@ -108,7 +107,7 @@ let mk_open_instance id idc gl m t=
       let typ=pf_unsafe_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
+      let (nam,_,_)=destProd (whd_all env evmap typ) in
 	match nam with
 	    Name id -> id
 	  | Anonymous ->  dummy_bvid in
@@ -116,8 +115,10 @@ let mk_open_instance id idc gl m t=
   let rec aux n avoid env evmap decls =
     if Int.equal n 0 then evmap, decls else
       let nid=(fresh_id avoid var_id gl) in
-      let evmap, (c, _) = Evarutil.new_type_evar env evmap Evd.univ_flexible in
-      let decl = (Name nid,None,c) in
+      let evmap = Sigma.Unsafe.of_evar_map evmap in
+      let Sigma ((c, _), evmap, _) = Evarutil.new_type_evar env evmap Evd.univ_flexible in
+      let evmap = Sigma.to_evar_map evmap in
+      let decl = LocalAssum (Name nid, c) in
 	aux (n-1) (nid::avoid) (Environ.push_rel decl env) evmap (decl::decls) in
   let evmap, decls = aux m [] env evmap [] in
     evmap, decls, revt
@@ -134,9 +135,9 @@ let left_instance_tac (inst,id) continue seq=
 	    [tclTHENLIST
 	       [Proofview.V82.of_tactic introf;
                 pf_constr_of_global id (fun idc ->
-		(fun gls->generalize
+		(fun gls-> Proofview.V82.of_tactic (generalize
 		   [mkApp(idc,
-			  [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls));
+			  [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])]) gls));
 		Proofview.V82.of_tactic introf;
 		tclSOLVE [wrap 1 false continue
 			    (deepen (record (id,None) seq))]];
@@ -155,12 +156,12 @@ let left_instance_tac (inst,id) continue seq=
 		      (mkApp(idc,[|ot|])) rc in
 		  let evmap, _ =
 		    try Typing.type_of (pf_env gl) evmap gt
-		    with e when Errors.noncritical e ->
+		    with e when CErrors.noncritical e ->
 		      error "Untypable instance, maybe higher-order non-prenex quantification" in
-		    tclTHEN (Refiner.tclEVARS evmap) (generalize [gt]) gl)
+		    tclTHEN (Refiner.tclEVARS evmap) (Proofview.V82.of_tactic (generalize [gt])) gl)
 	    else
 	      pf_constr_of_global id (fun idc ->
-		generalize [mkApp(idc,[|t|])])
+		Proofview.V82.of_tactic (generalize [mkApp(idc,[|t|])]))
 	  in
 	    tclTHENLIST
 	      [special_generalize;
diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml
index e676a8a9..ffb63af0 100644
--- a/plugins/firstorder/rules.ml
+++ b/plugins/firstorder/rules.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Term
@@ -19,6 +19,7 @@ open Formula
 open Sequent
 open Globnames
 open Locus
+open Context.Named.Declaration
 
 type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic
 
@@ -34,12 +35,13 @@ let wrap n b continue seq gls=
     if i<=0 then seq else
       match nc with
 	  []->anomaly (Pp.str "Not the expected number of hyps")
-	| ((id,_,typ) as nd)::q->
+	| nd::q->
+            let id = get_id nd in
 	    if occur_var env id (pf_concl gls) ||
 	      List.exists (occur_var_in_decl env id) ctx then
 		(aux (i-1) q (nd::ctx))
 	    else
-	      add_formula Hyp (VarRef id) typ (aux (i-1) q (nd::ctx)) gls in
+	      add_formula Hyp (VarRef id) (get_type nd) (aux (i-1) q (nd::ctx)) gls in
   let seq1=aux n nc [] in
   let seq2=if b then
     add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in
@@ -50,13 +52,13 @@ let basename_of_global=function
   | _->assert false
 
 let clear_global=function
-    VarRef id->clear [id]
+    VarRef id-> Proofview.V82.of_tactic (clear [id])
   | _->tclIDTAC
 
 (* connection rules *)
 
 let axiom_tac t seq=
-  try pf_constr_of_global (find_left t seq) exact_no_check
+  try pf_constr_of_global (find_left t seq) (fun c -> Proofview.V82.of_tactic (exact_no_check c))
   with Not_found->tclFAIL 0 (Pp.str "No axiom link")
 
 let ll_atom_tac a backtrack id continue seq=
@@ -65,7 +67,7 @@ let ll_atom_tac a backtrack id continue seq=
       tclTHENLIST
 	[pf_constr_of_global (find_left a seq) (fun left ->
 	  pf_constr_of_global id (fun id -> 
-	    generalize [mkApp(id, [|left|])]));
+	    Proofview.V82.of_tactic (generalize [mkApp(id, [|left|])])));
 	 clear_global id;
 	 Proofview.V82.of_tactic intro]
     with Not_found->tclFAIL 0 (Pp.str "No link"))
@@ -133,7 +135,7 @@ let ll_ind_tac (ind,u as indu) largs backtrack id continue seq gl=
        let newhyps idc =List.init lp (myterm idc) in
 	 tclIFTHENELSE
 	   (tclTHENLIST
-	      [pf_constr_of_global id (fun idc -> generalize (newhyps idc));
+	      [pf_constr_of_global id (fun idc -> Proofview.V82.of_tactic (generalize (newhyps idc)));
 	       clear_global id;
 	       tclDO lp (Proofview.V82.of_tactic intro)])
 	   (wrap lp false continue seq) backtrack gl
@@ -149,9 +151,9 @@ let ll_arrow_tac a b c backtrack id continue seq=
 	     clear_global id;
 	     wrap 1 false continue seq];
 	  tclTHENS (Proofview.V82.of_tactic (cut cc))
-            [pf_constr_of_global id exact_no_check;
+            [pf_constr_of_global id (fun c -> Proofview.V82.of_tactic (exact_no_check c));
 	     tclTHENLIST
-	       [pf_constr_of_global id (fun idc -> generalize [d idc]);
+	       [pf_constr_of_global id (fun idc -> Proofview.V82.of_tactic (generalize [d idc]));
 		clear_global id;
 		Proofview.V82.of_tactic introf;
 		Proofview.V82.of_tactic introf;
@@ -190,7 +192,7 @@ let ll_forall_tac prod backtrack id continue seq=
 	   (fun gls->
 	      let id0=pf_nth_hyp_id gls 1 in
               let term=mkApp(idc,[|mkVar(id0)|]) in
-		tclTHEN (generalize [term]) (clear [id0]) gls));
+		tclTHEN (Proofview.V82.of_tactic (generalize [term])) (Proofview.V82.of_tactic (clear [id0])) gls));
 	   clear_global id;
 	   Proofview.V82.of_tactic intro;
 	   tclCOMPLETE (wrap 1 false continue (deepen seq))];
@@ -210,6 +212,6 @@ let defined_connectives=lazy
 let normalize_evaluables=
   onAllHypsAndConcl
     (function
-	 None->unfold_in_concl (Lazy.force defined_connectives)
+	 None-> Proofview.V82.of_tactic (unfold_in_concl (Lazy.force defined_connectives))
        | Some id ->
-	   unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly))
+	   Proofview.V82.of_tactic (unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly)))
diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml
index 3e8033da..1248b60a 100644
--- a/plugins/firstorder/sequent.ml
+++ b/plugins/firstorder/sequent.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 open Term
-open Errors
+open CErrors
 open Util
 open Formula
 open Unify
diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml
index 72e9371b..51bd3009 100644
--- a/plugins/fourier/fourierR.ml
+++ b/plugins/fourier/fourierR.ml
@@ -16,9 +16,9 @@ open Term
 open Tactics
 open Names
 open Globnames
-open Tacmach
 open Fourier
 open Contradiction
+open Proofview.Notations
 
 (******************************************************************************
 Opérations sur les combinaisons linéaires affines.
@@ -412,13 +412,6 @@ let tac_zero_infeq_false gl (n,d) =
 	      (tac_zero_inf_pos gl (-n,d)))
 ;;
 
-let create_meta () = mkMeta(Evarutil.new_meta());;
-
-let my_cut c gl=
-     let concl = pf_concl gl in
-       apply_type (mkProd(Anonymous,c,concl)) [create_meta()] gl
-;;
-
 let exact = exact_check;;
 
 let tac_use h =
@@ -451,7 +444,11 @@ let is_ineq (h,t) =
 ;;
 *)
 
-let list_of_sign s = List.map (fun (x,_,z)->(x,z)) s;;
+let list_of_sign s =
+  let open Context.Named.Declaration in
+  List.map (function LocalAssum (name, typ) -> name, typ
+                   | LocalDef (name, _, typ) -> name, typ)
+           s;;
 
 let mkAppL a =
    let l = Array.to_list a in
@@ -462,7 +459,7 @@ exception GoalDone
 
 (* Résolution d'inéquations linéaires dans R *)
 let rec fourier () =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
     let concl = Proofview.Goal.concl gl in
     Coqlib.check_required_library ["Coq";"fourier";"Fourier"];
     let goal = strip_outer_cast concl in
@@ -504,11 +501,11 @@ let rec fourier () =
 		        with NoIneq -> ())
               hyps;
     (* lineq = les inéquations découlant des hypothèses *)
-    if !lineq=[] then Errors.error "No inequalities";
+    if !lineq=[] then CErrors.error "No inequalities";
     let res=fourier_lineq (!lineq) in
     let tac=ref (Proofview.tclUNIT ()) in
     if res=[]
-    then Errors.error "fourier failed"
+    then CErrors.error "fourier failed"
     (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *)
     else (match res with
         [(cres,sres,lc)]->
@@ -586,7 +583,7 @@ let rec fourier () =
                       then tac_zero_inf_false gl (rational_to_fraction cres)
                       else tac_zero_infeq_false gl (rational_to_fraction cres)
            in
-           tac:=(Tacticals.New.tclTHENS (Proofview.V82.tactic (my_cut ineq))
+           tac:=(Tacticals.New.tclTHENS (cut ineq)
                      [Tacticals.New.tclTHEN (change_concl
 			       (mkAppL [| get coq_not; ineq|]
 				       ))
@@ -622,7 +619,7 @@ let rec fourier () =
 (*    ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *)
       !tac
 (*      ((tclABSTRACT None !tac) gl) *)
-  end
+  end }
 ;;
 
 (*
diff --git a/plugins/fourier/fourier_plugin.mllib b/plugins/fourier/fourier_plugin.mlpack
index 0383b1a8..b6262f8a 100644
--- a/plugins/fourier/fourier_plugin.mllib
+++ b/plugins/fourier/fourier_plugin.mlpack
@@ -1,4 +1,3 @@
 Fourier
 FourierR
 G_fourier
-Fourier_plugin_mod
diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml
index 169a7060..b0ffc775 100644
--- a/plugins/funind/functional_principles_proofs.ml
+++ b/plugins/funind/functional_principles_proofs.ml
@@ -1,20 +1,20 @@
 open Printer
-open Errors
+open CErrors
 open Util
 open Term
 open Vars
-open Context
 open Namegen
 open Names
-open Declarations
 open Pp
 open Tacmach
+open Termops
 open Proof_type
 open Tacticals
 open Tactics
 open Indfun_common
 open Libnames
 open Globnames
+open Context.Rel.Declaration
 
 (* let msgnl = Pp.msgnl *)
 
@@ -27,7 +27,7 @@ let observe strm =
 let do_observe_tac s tac g =
  try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v
  with e ->
-   let e = Cerrors.process_vernac_interp_error e in
+   let e = ExplainErr.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 );
@@ -52,17 +52,17 @@ let rec print_debug_queue e =
       let _ =
 	match e with
 	| Some e ->
-	   Pp.msg_debug (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal)
+	   Feedback.msg_debug (hov 0 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal))
 	| None ->
 	   begin
-	     Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal);
+	     Feedback.msg_debug (str " from " ++ lmsg ++ str " on goal" ++ fnl() ++ goal);
 	   end in
       print_debug_queue None ;
     end
 
 let observe strm =
   if do_observe ()
-  then Pp.msg_debug strm
+  then Feedback.msg_debug strm
   else ()
 
 let do_observe_tac s tac g = 
@@ -74,9 +74,9 @@ let do_observe_tac s tac g =
     ignore(Stack.pop debug_queue);
     v
   with reraise ->
-    let reraise = Errors.push reraise in
+    let reraise = CErrors.push reraise in
     if not (Stack.is_empty debug_queue)
-    then print_debug_queue (Some (fst (Cerrors.process_vernac_interp_error reraise)));
+    then print_debug_queue (Some (fst (ExplainErr.process_vernac_interp_error reraise)));
     iraise reraise
 
 let observe_tac_stream s tac g =
@@ -127,8 +127,7 @@ let finish_proof dynamic_infos g =
 let refine c =
   Tacmach.refine c
 
-let thin l =
-  Tacmach.thin_no_check l
+let thin l = Proofview.V82.of_tactic (Tactics.clear l)
 
 let eq_constr u v = eq_constr_nounivs u v
 
@@ -142,7 +141,7 @@ let is_trivial_eq t =
 	    eq_constr t1 t2 && eq_constr a1 a2
 	| _ -> false
     end
-  with e when Errors.noncritical e -> false
+  with e when CErrors.noncritical e -> false
   in
 (*   observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *)
   res
@@ -168,7 +167,7 @@ let is_incompatible_eq t =
 	    (eq_constr u1 u2 &&
 	       incompatible_constructor_terms t1 t2)
 	| _ -> false
-    with e when Errors.noncritical e -> false
+    with e when CErrors.noncritical e -> false
   in
   if res then   observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t);
   res
@@ -224,12 +223,12 @@ let isAppConstruct ?(env=Global.env ()) t =
 
 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
+    CClosure.norm_val (CClosure.create_clos_infos flgs env) (CClosure.inject (Reductionops.nf_evar sigma t)) in
+  clos_norm_flags CClosure.betaiotazeta  Environ.empty_env Evd.empty
 
 
 
-let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
+let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type  =
   let nochange ?t' msg  =
     begin
       observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t  ++ str "    " ++ match t' with None -> str "" | Some t -> Printer.pr_lconstr t );
@@ -255,7 +254,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
 	  then
 	    (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0))
 	  else nochange "not an equality"
-      with e when Errors.noncritical e -> nochange "not an equality"
+      with e when CErrors.noncritical e -> nochange "not an equality"
     in
     if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs";
     let rec compute_substitution sub t1 t2 =
@@ -282,7 +281,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
 	  List.fold_left2 compute_substitution sub args1 args2
 	end
       else
-	if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_betadeltaiota env t1) t2)  "cannot solve (diff)"
+	if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_all env t1) t2)  "cannot solve (diff)"
     in
     let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in
     let sub = compute_substitution sub (fst t1) (fst t2) in
@@ -304,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
-	(fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) ->
+	(fun i (end_of_type,ctxt_size,witness_fun) decl ->
 	   try
 	     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))
+	     if is_local_def decl then anomaly (Pp.str "can not redefine a rel!");
+	     (Termops.pop end_of_type,ctxt_size,mkLetIn (get_name decl, witness, get_type decl, witness_fun))
 	   with Not_found  ->
 	     (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun)
 	)
@@ -371,12 +370,12 @@ let isLetIn t =
     | _ -> false
 
 
-let h_reduce_with_zeta =
-  reduce
+let h_reduce_with_zeta cl =
+  Proofview.V82.of_tactic (reduce
     (Genredexpr.Cbv
        {Redops.all_flags
 	with Genredexpr.rDelta = false;
-       })
+       }) cl)
 
 
 
@@ -536,7 +535,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
 		(scan_type new_context new_t')
 	    with Failure "NoChange" ->
 	      (* Last thing todo : push the rel in the context and continue *)
-	      scan_type ((x,None,t_x)::context) t'
+	      scan_type (LocalAssum (x,t_x) :: context) t'
 	  end
       end
     else
@@ -626,8 +625,8 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos =
 let my_orelse tac1 tac2 g =
   try
     tac1 g
-  with e when Errors.noncritical e ->
-(*     observe (str "using snd tac since : " ++ Errors.print e); *)
+  with e when CErrors.noncritical e ->
+(*     observe (str "using snd tac since : " ++ CErrors.print e); *)
     tac2 g
 
 let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id =
@@ -705,9 +704,9 @@ let build_proof
 		  in
 		  tclTHENSEQ
 		    [
-		      Simple.generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps));
+		      Proofview.V82.of_tactic (generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)));
 		      thin dyn_infos.rec_hyps;
-		      pattern_option [Locus.AllOccurrencesBut [1],t] None;
+		      Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],t] None);
 		      (fun g -> observe_tac "toto" (
 			 tclTHENSEQ [Proofview.V82.of_tactic (Simple.case t);
 				     (fun g' ->
@@ -736,7 +735,8 @@ let build_proof
 		      tclTHEN
 			(Proofview.V82.of_tactic intro)
 			(fun g' ->
-			   let (id,_,_) = pf_last_hyp g' in
+                           let open Context.Named.Declaration in
+			   let id = pf_last_hyp g' |> get_id in
 			   let new_term =
 			     pf_nf_betaiota g'
 			       (mkApp(dyn_infos.info,[|mkVar id|]))
@@ -921,7 +921,9 @@ let generalize_non_dep hyp g =
   let env = Global.env () in
   let hyp_typ = pf_unsafe_type_of g (mkVar hyp) in
   let to_revert,_ =
-    Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) ->
+    let open Context.Named.Declaration in
+    Environ.fold_named_context_reverse (fun (clear,keep) decl ->
+      let hyp = get_id decl in
       if Id.List.mem hyp hyps
         || List.exists (Termops.occur_var_in_decl env hyp) keep
 	|| Termops.occur_var env hyp hyp_typ
@@ -932,15 +934,15 @@ let generalize_non_dep hyp g =
   in
 (*   observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *)
   tclTHEN
-    ((* observe_tac "h_generalize" *) (Simple.generalize  (List.map mkVar to_revert) ))
+    ((* observe_tac "h_generalize" *) (Proofview.V82.of_tactic (generalize  (List.map mkVar to_revert) )))
     ((* observe_tac "thin" *) (thin to_revert))
     g
 
-let id_of_decl (na,_,_) =  (Nameops.out_name na)
+let id_of_decl decl = Nameops.out_name (get_name decl)
 let var_of_decl decl = mkVar (id_of_decl decl)
 let revert idl =
   tclTHEN
-    (generalize (List.map mkVar idl))
+    (Proofview.V82.of_tactic (generalize (List.map mkVar idl)))
     (thin idl)
 
 let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num =
@@ -1023,7 +1025,7 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a
 		{finfos with
 		   equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with
 					      ConstRef c -> c
-					    | _ -> Errors.anomaly (Pp.str "Not a constant")
+					    | _ -> CErrors.anomaly (Pp.str "Not a constant")
 					 )
 		}
 	  | _ -> ()
@@ -1044,7 +1046,8 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a
       (
 	fun g' ->
 	  let just_introduced = nLastDecls nb_intro_to_do g' in
-	  let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in
+          let open Context.Named.Declaration in
+	  let just_introduced_id = List.map get_id just_introduced in
 	  tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma))
 		  (revert just_introduced_id) g'
       )
@@ -1069,11 +1072,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 	 (Name new_id)
       )
     in
-    let fresh_decl =
-      (fun (na,b,t) ->
-	 (fresh_id na,b,t)
-      )
-    in
+    let fresh_decl = map_name fresh_id in
     let princ_info : elim_scheme =
       { princ_info with
 	  params = List.map fresh_decl princ_info.params;
@@ -1086,7 +1085,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
       match Global.body_of_constant const with
 	| Some body ->
 	     Tacred.cbv_norm_flags
-	       (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+	       (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA])
 	       (Global.env ())
 	       (Evd.empty)
 	       body
@@ -1120,11 +1119,11 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 	)
     in
     observe (str "full_params := " ++
-	       prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na))
+	       prlist_with_sep spc (fun decl -> Ppconstr.pr_id (Nameops.out_name (get_name decl)))
 	       full_params
 	    );
     observe (str "princ_params := " ++
-	       prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na))
+	       prlist_with_sep spc (fun decl -> Ppconstr.pr_id (Nameops.out_name (get_name decl)))
 	       princ_params
 	    );
     observe (str "fbody_with_full_params := " ++
@@ -1165,7 +1164,8 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 	    in
 	    let pte_to_fix,rev_info =
 	      List.fold_left_i
-		(fun i (acc_map,acc_info) (pte,_,_) ->
+		(fun i (acc_map,acc_info) decl ->
+		   let pte = get_name decl in
 		   let infos = info_array.(i) in
 		   let type_args,_ = decompose_prod infos.types in
 		   let nargs = List.length type_args in
@@ -1227,10 +1227,10 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 	      if this_fix_info.idx + 1 = 0
 	      then tclIDTAC (* Someone  tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *)
 	      else
-		observe_tac_stream (str "h_fix " ++ int (this_fix_info.idx +1) ) (fix (Some this_fix_info.name) (this_fix_info.idx +1))
+		observe_tac_stream (str "h_fix " ++ int (this_fix_info.idx +1) ) (Proofview.V82.of_tactic (fix (Some this_fix_info.name) (this_fix_info.idx +1)))
 	    else
-	      Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1)
-		other_fix_infos 0
+	      Proofview.V82.of_tactic (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 *)
@@ -1259,7 +1259,8 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 		 let args = nLastDecls nb_args g in
 		 let fix_body = fix_info.body_with_param in
 (* 		 observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *)
-		 let args_id = List.map (fun (id,_,_) -> id) args in
+                 let open Context.Named.Declaration in
+		 let args_id = List.map get_id args in
 		 let dyn_infos =
 		   {
 		     nb_rec_hyps = -100;
@@ -1276,7 +1277,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 		       (do_replace evd
 			  full_params
 			  (fix_info.idx + List.length princ_params)
-			  (args_id@(List.map (fun (id,_,_) -> Nameops.out_name id ) princ_params))
+			  (args_id@(List.map (fun decl -> Nameops.out_name (get_name decl)) princ_params))
 			  (all_funs.(fix_info.num_in_block))
 			  fix_info.num_in_block
 			  all_funs
@@ -1317,8 +1318,9 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 	    [
 	      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
+	         let args = nLastDecls nb_args g in
+                 let open Context.Named.Declaration in
+		 let args_id = List.map get_id args in
 		 let dyn_infos =
 		   {
 		     nb_rec_hyps = -100;
@@ -1334,7 +1336,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 		 in
 		 let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in
 		 tclTHENSEQ
-		   [unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))];
+		   [Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]);
 		    let do_prove =
 		      build_proof
 			interactive_proof
@@ -1403,7 +1405,7 @@ let prove_with_tcc tcc_lemma_constr eqs : tactic =
 (* 		 let ids = List.filter (fun id -> not (List.mem id ids)) ids' in  *)
 (* 		 rewrite *)
 (* 	      ) *)
-	      Eauto.gen_eauto (false,5) [] (Some [])
+	      Proofview.V82.of_tactic (Eauto.gen_eauto (false,5) [] (Some []))
 	    ]
 	    gls
 
@@ -1460,7 +1462,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
 		  (fun g ->
 		     if is_mes
 		     then
-		       unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g
+		       Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force ltof_ref))]) g
 		     else tclIDTAC g
 		  );
 		  observe_tac "rew_and_finish"
@@ -1472,7 +1474,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
 			    tclCOMPLETE(
 				    Eauto.eauto_with_bases
 				      (true,5)
-				      [Evd.empty,Lazy.force refl_equal]
+				      [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}]
 				      [Hints.Hint_db.empty empty_transparent_state false]
 				  )
 			   )
@@ -1520,7 +1522,7 @@ let prove_principle_for_gen
       avoid := new_id :: !avoid;
       Name new_id
   in
-  let fresh_decl (na,b,t) = (fresh_id na,b,t) in
+  let fresh_decl = map_name fresh_id in
   let princ_info : elim_scheme =
     { princ_info with
 	params = List.map fresh_decl princ_info.params;
@@ -1550,11 +1552,11 @@ let prove_principle_for_gen
   in
   let rec_arg_id =
     match List.rev post_rec_arg with
-      | (Name id,_,_)::_ -> id
+      | (LocalAssum (Name id,_) | LocalDef (Name id,_,_)) :: _ -> id
       | _ -> assert false
   in
 (*   observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *)
-  let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in
+  let subst_constrs = List.map (fun decl -> mkVar (Nameops.out_name (get_name decl))) (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
@@ -1562,7 +1564,7 @@ let prove_principle_for_gen
     Nameops.out_name (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id)))))
   in
   let revert l =
-    tclTHEN (Tactics.Simple.generalize (List.map mkVar l)) (clear l)
+    tclTHEN (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) (Proofview.V82.of_tactic (clear l))
   in
   let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in
   let prove_rec_arg_acc g =
@@ -1582,7 +1584,7 @@ let prove_principle_for_gen
       )
       g
   in
-  let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in
+  let args_ids = List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.args in
   let lemma =
     match !tcc_lemma_ref with
      | None -> error "No tcc proof !!"
@@ -1608,7 +1610,7 @@ let prove_principle_for_gen
       in
       tclTHENSEQ
 	[
-	  generalize [lemma];
+	  Proofview.V82.of_tactic (generalize [lemma]);
 	  Proofview.V82.of_tactic (Simple.intro hid);
 	  Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid));
 	  (fun g ->
@@ -1629,7 +1631,7 @@ let prove_principle_for_gen
     [
       observe_tac "start_tac" start_tac;
       h_intros
-	(List.rev_map (fun (na,_,_) -> Nameops.out_name na)
+	(List.rev_map (fun decl -> Nameops.out_name (get_name decl))
 	   (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params)
 	);
       (* observe_tac "" *) Proofview.V82.of_tactic (assert_by
@@ -1640,7 +1642,7 @@ let prove_principle_for_gen
 (*       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 " *) (fix (Some fix_id) (List.length args_ids + 1));
+      (* observe_tac "h_fix " *) (Proofview.V82.of_tactic (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_unsafe_type_of g (mkVar fix_id) )); tclIDTAC g); *)
       h_intros (List.rev (acc_rec_arg_id::args_ids));
       Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref));
@@ -1667,7 +1669,7 @@ let prove_principle_for_gen
 	 in
 	 let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar  acc_rec_arg_id|])) in
 	 let predicates_names =
-	   List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.predicates
+	   List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.predicates
 	 in
 	 let pte_info =
 	   { proving_tac =
@@ -1683,7 +1685,7 @@ let prove_principle_for_gen
 		       is_mes acc_inv fix_id
 
 		       (!tcc_list@(List.map
-			   (fun (na,_,_) -> (Nameops.out_name na))
+			   (fun decl -> (Nameops.out_name (get_name decl)))
 			   (princ_info.args@princ_info.params)
 			)@ ([acc_rec_arg_id])) eqs
 		    )
@@ -1712,7 +1714,7 @@ let prove_principle_for_gen
 	 (* observe_tac "instanciate_hyps_with_args"  *)
 	   (instanciate_hyps_with_args
 	      make_proof
-	      (List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.branches)
+	      (List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.branches)
 	      (List.rev args_ids)
 	   )
 	   gl'
diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml
index c47602bd..5e72b867 100644
--- a/plugins/funind/functional_principles_types.ml
+++ b/plugins/funind/functional_principles_types.ml
@@ -1,24 +1,25 @@
 open Printer
-open Errors
+open CErrors
 open Util
 open Term
 open Vars
-open Context
 open Namegen
 open Names
 open Pp
 open Entries
 open Tactics
+open Context.Rel.Declaration
 open Indfun_common
 open Functional_principles_proofs
 open Misctypes
+open Sigma.Notations
 
 exception Toberemoved_with_rel of int*constr
 exception Toberemoved
 
 let observe s =
   if do_observe ()
-  then Pp.msg_debug s
+  then Feedback.msg_debug s
 
 (*
    Transform an inductive induction principle into
@@ -29,14 +30,16 @@ 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:Id.t list) (predicates:rel_context)  : rel_context =
+  let rec change_predicates_names (avoid:Id.t list) (predicates:Context.Rel.t)  : Context.Rel.t =
     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 (Pp.str "Anonymous property binder ")
+    | decl :: predicates ->
+       (match Context.Rel.Declaration.get_name decl with
+	| Name x ->
+	   let id = Namegen.next_ident_away x avoid in
+	   Hashtbl.add tbl id x;
+	   set_name (Name id) decl :: change_predicates_names (id::avoid) predicates
+	| Anonymous -> anomaly (Pp.str "Anonymous property binder "))
   in
   let avoid = (Termops.ids_of_context env_with_params ) in
   let princ_type_info =
@@ -46,15 +49,16 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
   in
 (*   observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *)
 (*   observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *)
-  let change_predicate_sort i (x,_,t) =
+  let change_predicate_sort i decl =
     let new_sort = sorts.(i) in
-    let args,_ = decompose_prod t in
+    let args,_ = decompose_prod (get_type decl) in
     let real_args =
       if princ_type_info.indarg_in_concl
       then List.tl args
       else args
     in
-    Nameops.out_name x,None,compose_prod real_args (mkSort new_sort)
+    Context.Named.Declaration.LocalAssum (Nameops.out_name (Context.Rel.Declaration.get_name decl),
+                                          compose_prod real_args (mkSort new_sort))
   in
   let new_predicates =
     List.map_i
@@ -69,7 +73,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
 	   | _ -> error "Not a valid predicate"
 	)
   in
-  let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in
+  let ptes_vars = List.map Context.Named.Declaration.get_id new_predicates in
   let is_pte =
     let set = List.fold_right Id.Set.add ptes_vars Id.Set.empty in
     fun t ->
@@ -114,7 +118,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
 	| Rel n ->
 	    begin
 	      try match Environ.lookup_rel n env with
-		| _,_,t when is_dom t -> raise Toberemoved
+		| LocalAssum (_,t) | LocalDef (_,_,t) when is_dom t -> raise Toberemoved
 		| _ -> pre_princ,[]
 	      with Not_found -> assert false
 	    end
@@ -159,7 +163,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_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_env = Environ.push_rel (LocalAssum (x,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
 	 then (Termops.pop new_b), filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b
@@ -188,7 +192,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
 	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.t = get_name (Termops.ids_of_context env) x in
-	let new_env = Environ.push_rel (x,Some v,t) env in
+	let new_env = Environ.push_rel (LocalDef (x,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
 	then (Termops.pop new_b),filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b
@@ -227,7 +231,8 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
   in
   it_mkProd_or_LetIn
     (it_mkProd_or_LetIn
-       pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b)
+       pre_res (List.map (function Context.Named.Declaration.LocalAssum (id,b)   -> LocalAssum (Name (Hashtbl.find tbl id), b)
+                                 | Context.Named.Declaration.LocalDef (id,t,b) -> LocalDef (Name (Hashtbl.find tbl id), t, b))
           	      new_predicates)
     )
     princ_type_info.params
@@ -235,10 +240,12 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
 
 
 let change_property_sort evd toSort princ princName =
+  let open Context.Rel.Declaration in
   let princ_info = compute_elim_sig princ in
-  let change_sort_in_predicate (x,v,t) =
-    (x,None,
-     let args,ty = decompose_prod t in
+  let change_sort_in_predicate decl =
+    LocalAssum
+    (get_name decl,
+     let args,ty = decompose_prod (get_type decl) 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)
@@ -291,7 +298,7 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin
     (* 	  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, Ephemeron.create hook
+    get_proof_clean true, CEphemeron.create hook
   end
 
 
@@ -351,7 +358,7 @@ let generate_functional_principle (evd: Evd.evar_map ref)
      Don't forget to close the goal if an error is raised !!!!
   *)
   save false new_princ_name entry g_kind hook
-  with e when Errors.noncritical e ->
+  with e when CErrors.noncritical e ->
     begin
       begin
 	try
@@ -363,7 +370,7 @@ let generate_functional_principle (evd: Evd.evar_map ref)
 	  then Pfedit.delete_current_proof ()
 	  else ()
 	  else ()
-	with e when Errors.noncritical e -> ()
+	with e when CErrors.noncritical e -> ()
       end;
       raise (Defining_principle e)
     end
@@ -393,7 +400,7 @@ let get_funs_constant mp dp =
       match Global.body_of_constant const with
 	| Some body ->
 	    let body = Tacred.cbv_norm_flags
-	      (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+	      (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA])
 	      (Global.env ())
 	      (Evd.from_env (Global.env ()))
 	      body
@@ -503,7 +510,7 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con
 	0
 	(prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs)))
 	(fun _ _ _ -> ())
-    with e when Errors.noncritical e ->
+    with e when CErrors.noncritical e ->
        begin
 	 begin
 	   try
@@ -515,7 +522,7 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con
 		  then Pfedit.delete_current_proof ()
 		  else ()
 	     else ()
-	   with e when Errors.noncritical e -> ()
+	   with e when CErrors.noncritical e -> ()
 	 end;
 	 raise (Defining_principle e)
        end
@@ -648,12 +655,15 @@ let build_case_scheme fa =
     let this_block_funs_indexes = Array.to_list this_block_funs_indexes in
     List.assoc_f Constant.equal (fst (destConst funs)) this_block_funs_indexes
   in
-  let ind_fun =
+  let (ind, sf) =
 	 let ind = first_fun_kn,funs_indexes in
 	   (ind,Univ.Instance.empty)(*FIXME*),prop_sort
   in
-  let sigma, scheme = 
-    (fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf)  ind_fun in
+  let sigma = Sigma.Unsafe.of_evar_map sigma in
+  let Sigma (scheme, sigma, _) = 
+      Indrec.build_case_analysis_scheme_default env sigma ind sf
+  in
+  let sigma = Sigma.to_evar_map sigma in
   let scheme_type =  (Typing.unsafe_type_of env sigma ) scheme in
   let sorts =
     (fun (_,_,x) ->
diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4
index a15e46bf..42e49031 100644
--- a/plugins/funind/g_indfun.ml4
+++ b/plugins/funind/g_indfun.ml4
@@ -9,15 +9,16 @@
 open Compat
 open Util
 open Term
-open Vars
-open Names
 open Pp
 open Constrexpr
 open Indfun_common
 open Indfun
 open Genarg
-open Tacticals
+open Constrarg
 open Misctypes
+open Pcoq.Prim
+open Pcoq.Constr
+open Pcoq.Tactic
 
 DECLARE PLUGIN "recdef_plugin"
 
@@ -55,10 +56,13 @@ let pr_with_bindings_typed prc prlc (c,bl) =
 let pr_fun_ind_using_typed prc prlc _ opt_c =
   match opt_c with
     | None -> mt ()
-    | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b.Evd.it)
+    | Some b ->
+      let (b, _) = Tactics.run_delayed (Global.env ()) Evd.empty b in
+      spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b)
 
 
 ARGUMENT EXTEND fun_ind_using
+  TYPED AS constr_with_bindings option
   PRINTED BY pr_fun_ind_using_typed
   RAW_TYPED AS constr_with_bindings_opt
   RAW_PRINTED BY pr_fun_ind_using
@@ -86,9 +90,9 @@ let pr_intro_as_pat _prc _ _ pat =
 
 let out_disjunctive = function
   | loc, IntroAction (IntroOrAndPattern l) -> (loc,l)
-  | _ -> Errors.error "Disjunctive or conjunctive intro pattern expected."
+  | _ -> CErrors.error "Disjunctive or conjunctive intro pattern expected."
 
-ARGUMENT EXTEND with_names TYPED AS simple_intropattern_opt PRINTED BY pr_intro_as_pat
+ARGUMENT EXTEND with_names TYPED AS intropattern_opt PRINTED BY pr_intro_as_pat
 |   [ "as"  simple_intropattern(ipat) ] -> [ Some ipat ]
 | []  ->[ None ]
 END
@@ -119,12 +123,12 @@ TACTIC EXTEND snewfunind
 END
 
 
-let pr_constr_coma_sequence prc _ _ = prlist_with_sep pr_comma prc
+let pr_constr_comma_sequence prc _ _ = prlist_with_sep pr_comma prc
 
-ARGUMENT EXTEND constr_coma_sequence'
+ARGUMENT EXTEND constr_comma_sequence'
   TYPED AS constr_list
-  PRINTED BY pr_constr_coma_sequence
-| [ constr(c) "," constr_coma_sequence'(l) ] -> [ c::l ]
+  PRINTED BY pr_constr_comma_sequence
+| [ constr(c) "," constr_comma_sequence'(l) ] -> [ c::l ]
 | [ constr(c) ] -> [ [c] ]
 END
 
@@ -133,7 +137,7 @@ let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc
 ARGUMENT EXTEND auto_using'
   TYPED AS constr_list
   PRINTED BY pr_auto_using
-| [ "using" constr_coma_sequence'(l) ] -> [ l ]
+| [ "using" constr_comma_sequence'(l) ] -> [ l ]
 | [ ] -> [ [] ]
 END
 
@@ -144,10 +148,10 @@ module Tactic = Pcoq.Tactic
 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"
+  Genarg.create_arg "function_rec_definition_loc"
 
 let function_rec_definition_loc =
-  Pcoq.create_generic_entry "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc)
+  Pcoq.create_generic_entry Pcoq.utactic "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc)
 
 GEXTEND Gram
   GLOBAL: function_rec_definition_loc ;
@@ -158,6 +162,11 @@ GEXTEND Gram
 
 END
 
+let () =
+  let raw_printer _ _ _ (loc,body) = Ppvernac.pr_rec_definition body in
+  let printer _ _ _ _ = str "<Unavailable printer for rec_definition>" in
+  Pptactic.declare_extra_genarg_pprule wit_function_rec_definition_loc raw_printer printer printer
+
 (* TASSI: n'importe quoi ! *)
 VERNAC COMMAND EXTEND Function
    ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")]
@@ -186,18 +195,16 @@ END
 
 
 let warning_error names e =
-  let (e, _) = Cerrors.process_vernac_interp_error (e, Exninfo.null) in
+  let (e, _) = ExplainErr.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 (pr_enum Libnames.pr_reference names) ++
-	     if do_observe () then (spc () ++ Errors.print e) else mt ())
+       let names = pr_enum Libnames.pr_reference names in
+       let error = if do_observe () then (spc () ++ CErrors.print e) else mt () in
+       warn_cannot_define_graph (names,error)
     | Defining_principle e ->
-	Pp.msg_warning
-	  (str "Cannot define principle(s) for "++
-	     h 1 (pr_enum Libnames.pr_reference names) ++
-	     if do_observe () then Errors.print e else mt ())
+       let names = pr_enum Libnames.pr_reference names in
+       let error = if do_observe () then CErrors.print e else mt () in
+       warn_cannot_define_principle (names,error)
     | _ -> raise e
 
 
@@ -220,15 +227,15 @@ VERNAC COMMAND EXTEND NewFunctionalScheme
 		  ;
 		    try Functional_principles_types.build_scheme fas
 		    with Functional_principles_types.No_graph_found ->
-		      Errors.error ("Cannot generate induction principle(s)")
-		      | e when Errors.noncritical e ->
+		      CErrors.error ("Cannot generate induction principle(s)")
+		      | e when CErrors.noncritical e ->
 			  let names = List.map (fun (_,na,_) -> na) fas in
 			  warning_error names e
 
 		  end
 	      | _ -> assert false (* we can only have non empty  list *)
 	  end
-	  | e when Errors.noncritical e ->
+	  | e when CErrors.noncritical e ->
 	      let names = List.map (fun (_,na,_) -> na) fas in
 	      warning_error names e
       end
diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml
index 5d92fca5..52179ae5 100644
--- a/plugins/funind/glob_term_to_relation.ml
+++ b/plugins/funind/glob_term_to_relation.ml
@@ -7,14 +7,14 @@ open Glob_term
 open Glob_ops
 open Globnames
 open Indfun_common
-open Errors
+open CErrors
 open Util
 open Glob_termops
 open Misctypes
 
 let observe strm =
   if do_observe ()
-  then Pp.msg_debug strm
+  then Feedback.msg_debug strm
   else ()
 (*let observennl strm =
   if do_observe ()
@@ -335,15 +335,17 @@ let raw_push_named (na,raw_value,raw_typ) env =
     | Name id ->
 	let value = Option.map (fun x-> fst (Pretyping.understand env (Evd.from_env env) x)) raw_value in
 	let typ,ctx = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in
-	Environ.push_named (id,value,typ) env
+        let open Context.Named.Declaration in
+	Environ.push_named (of_tuple (id,value,typ)) env
 
 
 let add_pat_variables pat typ env : Environ.env =
   let rec add_pat_variables env pat typ  : Environ.env =
+    let open Context.Rel.Declaration in
     observe (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env));
 
     match pat with
-      | PatVar(_,na) -> Environ.push_rel (na,None,typ) env
+      | PatVar(_,na) -> Environ.push_rel (LocalAssum (na,typ)) env
       | PatCstr(_,c,patl,na) ->
 	  let Inductiveops.IndType(indf,indargs) =
 	    try Inductiveops.find_rectype env (Evd.from_env env) typ
@@ -351,15 +353,16 @@ let add_pat_variables pat typ env : Environ.env =
 	  in
 	  let constructors = Inductiveops.get_constructors env indf 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
+	  let cs_args_types :types list = List.map get_type 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 (
-      Context.fold_rel_context
-	(fun (na,v,t) (env,ctxt) ->
-	 match na with
+      Context.Rel.fold_outside
+	(fun decl (env,ctxt) ->
+         let _,v,t = Context.Rel.Declaration.to_tuple decl in
+	 match Context.Rel.Declaration.get_name decl with
 	   | Anonymous -> assert false
 	   | Name id ->
 	       let new_t =  substl ctxt t in
@@ -370,7 +373,8 @@ let add_pat_variables pat typ env : Environ.env =
 			  Option.fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++
 			  Option.fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ())
 		       );
-	       (Environ.push_named (id,new_v,new_t) env,mkVar id::ctxt)
+               let open Context.Named.Declaration in
+	       (Environ.push_named (of_tuple (id,new_v,new_t)) env,mkVar id::ctxt)
       )
 	(Environ.rel_context new_env)
 	~init:(env,[])
@@ -398,7 +402,8 @@ let rec pattern_to_term_and_type env typ  = function
       in
       let constructors = Inductiveops.get_constructors env indf 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 open Context.Rel.Declaration in
+      let cs_args_types :types list = List.map get_type constructor.Inductiveops.cs_args in
       let _,cstl = Inductiveops.dest_ind_family indf in
       let csta = Array.of_list cstl in
       let implicit_args =
@@ -597,9 +602,10 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 	let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in
 	let v_type = Typing.unsafe_type_of env (Evd.from_env env) v_as_constr in
 	let new_env =
+          let open Context.Named.Declaration in
 	  match n with
 	      Anonymous -> env
-	    | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env
+	    | Name id -> Environ.push_named (of_tuple (id,Some v_as_constr,v_type)) env
 	in
 	let b_res = build_entry_lc new_env funnames avoid b in
 	combine_results (combine_letin n) v_res b_res
@@ -875,7 +881,7 @@ exception Continue
 *)
 let rec rebuild_cons env nb_args relname args crossed_types depth rt =
   observe (str "rebuilding : " ++ pr_glob_constr rt);
-
+  let open Context.Rel.Declaration in
   match rt with
     | GProd(_,n,k,t,b) ->
 	let not_free_in_t id = not (is_free_in id t) in
@@ -895,7 +901,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 			  mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt])
 			in
 			let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in
-			let new_env = Environ.push_rel (n,None,t') env in
+			let new_env = Environ.push_rel (LocalAssum (n,t')) env in
 			let new_b,id_to_exclude =
 			  rebuild_cons new_env
 			    nb_args relname
@@ -915,7 +921,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		    observe (str "computing new type for eq : " ++ pr_glob_constr rt);
 		    let t' =
 		      try fst (Pretyping.understand env (Evd.from_env env) t)(*FIXME*)
-                      with e when Errors.noncritical e -> raise Continue
+                      with e when CErrors.noncritical e -> raise Continue
 		    in
 		    let is_in_b = is_free_in id b in
 		    let _keep_eq =
@@ -926,7 +932,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		    let subst_b =
 		      if is_in_b then b else  replace_var_by_term id rt b
 		    in
-		    let new_env = Environ.push_rel (n,None,t') env in
+		    let new_env = Environ.push_rel (LocalAssum (n,t')) env in
 		    let new_b,id_to_exclude =
 		      rebuild_cons
 			new_env
@@ -970,9 +976,8 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 			      (fun acc var_as_constr arg ->
 				 if isRel var_as_constr
 				 then
-				   let (na,_,_) =
-				     Environ.lookup_rel (destRel var_as_constr) env
-				   in
+                                   let open Context.Rel.Declaration in
+				   let na = get_name (Environ.lookup_rel (destRel var_as_constr) env) in
 				   match na with
 				     | Anonymous -> acc
 				     | Name id' ->
@@ -1010,7 +1015,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		    in
 		    let new_env =
 		      let t',ctx = Pretyping.understand env (Evd.from_env env) eq' in
-		      Environ.push_rel (n,None,t') env
+		      Environ.push_rel (LocalAssum (n,t')) env
 		    in
 		    let new_b,id_to_exclude =
 		      rebuild_cons
@@ -1048,7 +1053,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 	      with Continue -> 
 		observe (str "computing new type for prod : " ++ pr_glob_constr rt);
 		let t',ctx = Pretyping.understand env (Evd.from_env env) t in
-		let new_env = Environ.push_rel (n,None,t') env in
+		let new_env = Environ.push_rel (LocalAssum (n,t')) env in
 		let new_b,id_to_exclude =
 		  rebuild_cons new_env
 		    nb_args relname
@@ -1064,7 +1069,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 	    | _ ->
 		observe (str "computing new type for prod : " ++ pr_glob_constr rt);
 		let t',ctx = Pretyping.understand env (Evd.from_env env) t in
-		let new_env = Environ.push_rel (n,None,t') env in
+		let new_env = Environ.push_rel (LocalAssum (n,t')) env in
 		let new_b,id_to_exclude =
 		  rebuild_cons new_env
 		    nb_args relname
@@ -1085,7 +1090,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 	  let t',ctx = Pretyping.understand env (Evd.from_env env) t in
 	  match n with
 	    | Name id ->
-		let new_env = Environ.push_rel (n,None,t') env in
+		let new_env = Environ.push_rel (LocalAssum (n,t')) env in
 		let new_b,id_to_exclude =
 		  rebuild_cons new_env
 		    nb_args relname
@@ -1108,7 +1113,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 	  let t',ctx = Pretyping.understand env evd t in
 	  let evd = Evd.from_ctx ctx in
 	  let type_t' = Typing.unsafe_type_of env evd t' in
-	  let new_env = Environ.push_rel (n,Some t',type_t') env in
+	  let new_env = Environ.push_rel (LocalDef (n,t',type_t')) env in
 	  let new_b,id_to_exclude =
 	    rebuild_cons new_env
 	      nb_args relname
@@ -1132,7 +1137,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 	      depth t
 	  in
 	  let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in
-	  let new_env = Environ.push_rel (na,None,t') env in
+	  let new_env = Environ.push_rel (LocalAssum (na,t')) env in
 	  let new_b,id_to_exclude =
 	    rebuild_cons new_env
 	      nb_args relname
@@ -1212,13 +1217,13 @@ let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * bool)
 	   if Array.for_all
 	     (fun l ->
 		let (n',nt',is_defined') = List.nth l i in
-		Name.equal n n' && Notation_ops.eq_glob_constr nt nt' && (is_defined : bool) == is_defined')
+		Name.equal n n' && glob_constr_eq nt nt' && (is_defined : bool) == is_defined')
 	     rels_params
 	   then
 	     l := param::!l
 	)
 	rels_params.(0)
-    with e when Errors.noncritical e ->
+    with e when CErrors.noncritical e ->
       ()
   in
   List.rev !l
@@ -1254,12 +1259,13 @@ let do_build_inductive
   let relnames = Array.map mk_rel_id funnames in
   let relnames_as_set = Array.fold_right Id.Set.add relnames Id.Set.empty in
   (* Construction of the pseudo constructors *)
+  let open Context.Named.Declaration in
   let evd,env =
     Array.fold_right2
       (fun id c (evd,env) ->
        let evd,t = Typing.type_of env evd (mkConstU c) in
        evd,
-       Environ.push_named (id,None,t)
+       Environ.push_named (LocalAssum (id,t))
 			   (* try *)
 			   (*   Typing.e_type_of env evd (mkConstU c) *)
 			   (* with Not_found -> *)
@@ -1298,8 +1304,8 @@ let do_build_inductive
     *)
     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, 
-						 fst (with_full_print (Constrintern.interp_constr env evd) rel_ar)) env) env relnames rel_arities
+			     Environ.push_named (LocalAssum (rel_name,
+						             fst (with_full_print (Constrintern.interp_constr env evd) rel_ar))) env) env relnames rel_arities
   in
   (* and of the real constructors*)
   let constr i res =
@@ -1454,7 +1460,7 @@ let do_build_inductive
 	  str "while trying to define"++ spc () ++
 	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds))
 	    ++ fnl () ++
-	    Errors.print reraise
+	    CErrors.print reraise
 	in
  	observe msg;
 	raise reraise
@@ -1470,7 +1476,7 @@ let build_inductive evd funconstants funsargs returned_types rtl =
     do_build_inductive evd funconstants funsargs returned_types rtl;
     Detyping.print_universes := pu;
     Constrextern.print_universes := cu
-  with e when Errors.noncritical e ->
+  with e when CErrors.noncritical e ->
     Detyping.print_universes := pu;
     Constrextern.print_universes := cu;
     raise (Building_graph e)
diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml
index 291f835e..01e5ef7f 100644
--- a/plugins/funind/glob_termops.ml
+++ b/plugins/funind/glob_termops.ml
@@ -1,6 +1,6 @@
 open Pp
 open Glob_term
-open Errors
+open CErrors
 open Util
 open Names
 open Decl_kinds
diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml
index 3dbd4380..18817f50 100644
--- a/plugins/funind/indfun.ml
+++ b/plugins/funind/indfun.ml
@@ -1,4 +1,5 @@
-open Errors
+open Context.Rel.Declaration
+open CErrors
 open Util
 open Names
 open Term
@@ -10,12 +11,13 @@ open Glob_term
 open Declarations
 open Misctypes
 open Decl_kinds
+open Sigma.Notations
 
 let is_rec_info scheme_info =
-  let test_branche min acc (_,_,br) =
+  let test_branche min acc decl =
     acc || (
       let new_branche =
-	it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum br)) in
+	it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum (get_type decl))) in
       let free_rels_in_br = Termops.free_rels new_branche in
       let max = min + scheme_info.Tactics.npredicates in
       Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br
@@ -85,7 +87,7 @@ let functional_induction with_clean c princl pat =
       in
       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))
+      List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr ({ Tacexpr.delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) })),(None,pat),None))
         (args@c_list) encoded_pat_as_patlist
     in
     let princ' = Some (princ,bindings) in
@@ -112,7 +114,7 @@ let functional_induction with_clean c princl pat =
 	in
 	Tacticals.tclTHEN
 	  (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Proofview.V82.of_tactic (Equality.subst_gen (do_rewrite_dependent ()) [id]))) idl )
-	  (Tactics.reduce flag Locusops.allHypsAndConcl)
+	  (Proofview.V82.of_tactic (Tactics.reduce flag Locusops.allHypsAndConcl))
 	  g
       else Tacticals.tclIDTAC g
     in
@@ -130,6 +132,7 @@ let rec abstract_glob_constr c = function
   | 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)
+  | Constrexpr.LocalPattern _::bl -> assert false
 
 let interp_casted_constr_with_implicits env sigma impls c  =
   Constrintern.intern_gen Pretyping.WithoutTypeConstraint env ~impls
@@ -152,7 +155,8 @@ let build_newrecursive
 	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))
+        let open Context.Named.Declaration in
+        (Environ.push_named (LocalAssum (recname,arity)) env, Id.Map.add recname impl impls))
       (env0,Constrintern.empty_internalization_env) lnameargsardef in
   let recdef =
     (* Declare local notations *)
@@ -212,6 +216,7 @@ let rec local_binders_length = function
   | [] -> 0
   | Constrexpr.LocalRawDef _::bl -> 1 + local_binders_length bl
   | Constrexpr.LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl
+  | Constrexpr.LocalPattern _::bl -> assert false
 
 let prepare_body ((name,_,args,types,_),_) rt =
   let n = local_binders_length args in
@@ -220,7 +225,12 @@ let prepare_body ((name,_,args,types,_),_) rt =
   (fun_args,rt')
 
 let process_vernac_interp_error e =
-  fst (Cerrors.process_vernac_interp_error (e, Exninfo.null))
+  fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null))
+
+let warn_funind_cannot_build_inversion =
+  CWarnings.create ~name:"funind-cannot-build-inversion" ~category:"funind"
+    (fun e' -> strbrk "Cannot build inversion information" ++
+                 if do_observe () then (fnl() ++ CErrors.print e') else mt ())
 
 let derive_inversion fix_names =
   try
@@ -262,16 +272,22 @@ let derive_inversion fix_names =
 	functional_induction
 	fix_names_as_constant
 	lind;
-      with e when Errors.noncritical e ->
-      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 ->
+      with e when CErrors.noncritical e ->
       let e' = process_vernac_interp_error e in
-      msg_warning
-	(str "Cannot build inversion information (early)" ++
-	   if do_observe () then (fnl() ++ Errors.print e') else mt ())       
+      warn_funind_cannot_build_inversion e'
+  with e when CErrors.noncritical e ->
+    let e' = process_vernac_interp_error e in
+    warn_funind_cannot_build_inversion e'
+
+let warn_cannot_define_graph =
+  CWarnings.create ~name:"funind-cannot-define-graph" ~category:"funind"
+    (fun (names,error) -> strbrk "Cannot define graph(s) for " ++
+      h 1 names ++ error)
+
+let warn_cannot_define_principle =
+  CWarnings.create ~name:"funind-cannot-define-principle" ~category:"funind"
+  (fun (names,error) -> strbrk "Cannot define induction principle(s) for "++
+      h 1 names ++ error)
 
 let warning_error names e =
   let e = process_vernac_interp_error e in
@@ -279,33 +295,29 @@ let warning_error names e =
     match e with
       | ToShow e -> 
 	let e = process_vernac_interp_error e in
-	spc () ++ Errors.print e
+	spc () ++ CErrors.print e
       | _ -> 
 	if do_observe () 
 	then 
 	  let e = process_vernac_interp_error e in 
-	  (spc () ++ Errors.print e) 
+	  (spc () ++ CErrors.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)
+       let names = prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names in
+       warn_cannot_define_graph (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)
+       let names = prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names in
+       warn_cannot_define_principle (names,e_explain e)
     | _ -> raise e
 
 let error_error names e =
   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 -> spc () ++ CErrors.print e
+      | _ -> if do_observe () then (spc () ++ CErrors.print e) else mt ()
   in
   match e with
     | Building_graph e ->
@@ -373,7 +385,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error
 	Array.iter (add_Function is_general) funs_kn;
 	()
       end
-  with e when Errors.noncritical e ->
+  with e when CErrors.noncritical e ->
     on_error names e
 
 let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) =
@@ -463,7 +475,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas
 	   functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation
 	);
       derive_inversion [fname]
-    with e when Errors.noncritical e ->
+    with e when CErrors.noncritical e ->
       (* No proof done *)
       ()
   in
@@ -727,9 +739,9 @@ let rec add_args id new_args b =
 	   List.map (fun (e,o) -> add_args id new_args e,o) bl)
   | CCases(loc,sty,b_option,cel,cal) ->
       CCases(loc,sty,Option.map (add_args id new_args) b_option,
-	     List.map (fun (b,(na,b_option)) ->
+	     List.map (fun (b,na,b_option) ->
 			 add_args id new_args b,
-			 (na, 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) ->
@@ -751,10 +763,8 @@ let rec add_args id new_args b =
   | 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)
+  | CRecord (loc, pars) ->
+      CRecord (loc, List.map (fun (e,o) -> e, add_args id new_args o) pars)
   | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation")
   | CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization")
   | CPrim _ -> b
@@ -860,6 +870,7 @@ let make_graph (f_ref:global_reference) =
 					(fun (loc,n) ->
 					   CRef(Libnames.Ident(loc, Nameops.out_name n),None))
 					nal
+                                  | Constrexpr.LocalPattern _ -> assert false
 			       )
 			       nal_tas
 			    )
diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli
index e7206914..1c27bdfa 100644
--- a/plugins/funind/indfun.mli
+++ b/plugins/funind/indfun.mli
@@ -1,5 +1,9 @@
 open Misctypes
 
+val warn_cannot_define_graph : ?loc:Loc.t -> Pp.std_ppcmds * Pp.std_ppcmds -> unit
+
+val warn_cannot_define_principle : ?loc:Loc.t -> Pp.std_ppcmds * Pp.std_ppcmds -> unit
+
 val do_generate_principle :  
   bool -> 
   (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> 
diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml
index aa47e261..f56e9241 100644
--- a/plugins/funind/indfun_common.ml
+++ b/plugins/funind/indfun_common.ml
@@ -49,7 +49,7 @@ let locate_constant ref =
 
 let locate_with_msg msg f x =
   try f x
-  with Not_found -> raise (Errors.UserError("", msg))
+  with Not_found -> raise (CErrors.UserError("", msg))
 
 
 let filter_map filter f =
@@ -73,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 (Errors.UserError("chop_rlambda_n",
+	      raise (CErrors.UserError("chop_rlambda_n",
 				    str "chop_rlambda_n: Not enough Lambdas"))
   in
   chop_lambda_n []
@@ -85,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 (Errors.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products"))
+	  | _ -> raise (CErrors.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products"))
   in
   chop_prod_n []
 
@@ -110,7 +110,7 @@ let const_of_id id =
   in
   try Constrintern.locate_reference princ_ref
   with Not_found ->
-    Errors.errorlabstrm "IndFun.const_of_id"
+    CErrors.errorlabstrm "IndFun.const_of_id"
       (str "cannot find " ++ Nameops.pr_id id)
 
 let def_of_const t =
@@ -163,7 +163,7 @@ let save with_clean id const (locality,_,kind) hook =
 	(locality, ConstRef kn)
   in
   if with_clean then  Pfedit.delete_current_proof ();
-  Ephemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r);
+  CEphemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r);
   definition_message id
 
 
@@ -344,7 +344,7 @@ let pr_info f_info =
   (try
      Printer.pr_lconstr
        (Global.type_of_global_unsafe (ConstRef f_info.function_constant))
-   with e when Errors.noncritical e -> mt ()) ++ fnl () ++
+   with e when CErrors.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 () ++
@@ -371,7 +371,7 @@ let in_Function : function_info -> Libobject.obj =
 
 let find_or_none id =
   try Some
-    (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Errors.anomaly (Pp.str "Not a constant")
+    (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> CErrors.anomaly (Pp.str "Not a constant")
     )
   with Not_found -> None
 
@@ -399,7 +399,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 | _ -> Errors.anomaly (Pp.str "Not an inductive")
+    with | IndRef ind -> ind | _ -> CErrors.anomaly (Pp.str "Not an inductive")
   in
   let finfos =
     { function_constant = f;
@@ -476,13 +476,13 @@ let jmeq () =
   try
     Coqlib.check_required_library Coqlib.jmeq_module_name;
     Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq"
-  with e when Errors.noncritical e -> raise (ToShow e)
+  with e when CErrors.noncritical e -> raise (ToShow e)
 
 let jmeq_refl () =
   try
     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)
+  with e when CErrors.noncritical e -> raise (ToShow e)
 
 let h_intros l =
   tclMAP (fun x -> Proofview.V82.of_tactic (Tactics.Simple.intro x)) l
diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli
index 23f1da1b..e5c756f5 100644
--- a/plugins/funind/indfun_common.mli
+++ b/plugins/funind/indfun_common.mli
@@ -47,7 +47,7 @@ val jmeq : unit -> Term.constr
 val jmeq_refl : unit -> Term.constr
 
 val save : bool -> Id.t -> Safe_typing.private_constants Entries.definition_entry  -> Decl_kinds.goal_kind ->
-  unit Lemmas.declaration_hook Ephemeron.key -> unit
+  unit Lemmas.declaration_hook CEphemeron.key -> unit
 
 (* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and
    abort the proof
diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml
index a800c186..26fc88a6 100644
--- a/plugins/funind/invfun.ml
+++ b/plugins/funind/invfun.ml
@@ -5,9 +5,10 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
+
 open Tacexpr
 open Declarations
-open Errors
+open CErrors
 open Util
 open Names
 open Term
@@ -19,6 +20,8 @@ open Tactics
 open Indfun_common
 open Tacmach
 open Misctypes
+open Termops
+open Context.Rel.Declaration
 
 (* Some pretty printing function for debugging purpose *)
 
@@ -50,7 +53,7 @@ let pr_constr_with_binding prc (c,bl) :  Pp.std_ppcmds =
 
 let observe strm =
   if do_observe ()
-  then Pp.msg_debug strm
+  then Feedback.msg_debug strm
   else ()
 
 (*let observennl strm =
@@ -62,16 +65,16 @@ let observe strm =
 let do_observe_tac s tac g =
   let goal =
     try Printer.pr_goal g
-    with e when Errors.noncritical e -> assert false
+    with e when CErrors.noncritical e -> assert false
   in
   try
     let v = tac g in
     msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v
   with reraise ->
-    let reraise = Errors.push reraise in
-    let e = Cerrors.process_vernac_interp_error reraise in
-    observe (str "observation "++ s++str " raised exception " ++
-	     Errors.iprint e ++ str " on goal " ++ goal );
+    let reraise = CErrors.push reraise in
+    let e = ExplainErr.process_vernac_interp_error reraise in
+    observe (hov 0 (str "observation "++ s++str " raised exception " ++
+	     CErrors.iprint e ++ str " on goal" ++ fnl() ++ goal ));
     iraise reraise;;
 
 
@@ -87,10 +90,11 @@ let observe_tac s tac g =
 
 (* [nf_zeta] $\zeta$-normalization of a term *)
 let nf_zeta =
-  Reductionops.clos_norm_flags  (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+  Reductionops.clos_norm_flags  (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA])
     Environ.empty_env
     Evd.empty
 
+let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl
 
 (* (\* [id_to_constr id] finds the term associated to [id] in the global environment *\) *)
 (* let id_to_constr id = *)
@@ -133,18 +137,21 @@ let generate_type evd g_to_f f graph i =
   let fun_ctxt,res_type =
     match ctxt with
       | [] | [_] -> anomaly (Pp.str "Not a valid context")
-      | (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type
+      | decl :: fun_ctxt -> fun_ctxt, get_type decl
   in
   let rec args_from_decl i accu = function
   | [] -> accu
-  | (_, Some _, _) :: l ->
+  | LocalDef _ :: 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 filter = function (Name id,_,_) -> Some id | (Anonymous,_,_) -> None in
+  let filter = fun decl -> match get_name decl with
+			   | 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
@@ -170,12 +177,12 @@ let generate_type evd g_to_f f graph i =
     \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res,  \]
     i*)
   let pre_ctxt =
-    (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(f,args_as_rels)),res_type)::fun_ctxt
+    LocalAssum (Name res_id, lift 1 res_type) :: LocalDef (Name fv_id, mkApp (f,args_as_rels), res_type) :: fun_ctxt
   in
   (*i and we can return the solution depending on which lemma type we are defining i*)
   if g_to_f
-  then (Anonymous,None,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph
-  else (Anonymous,None,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph
+  then LocalAssum (Anonymous,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph
+  else LocalAssum (Anonymous,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph
 
 
 (*
@@ -259,10 +266,10 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
     (* and built the intro pattern for each of them *)
     let intro_pats =
       List.map
-	(fun (_,_,br_type) ->
+	(fun decl ->
 	   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))))
+	     (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum (get_type decl)))))
 	)
 	branches
     in
@@ -358,18 +365,18 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
 	    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));
+						 | _ -> Proofview.V82.of_tactic (intro_patterns false l));
 	    (* unfolding of all the defined variables introduced by this branch *)
 	    (* observe_tac "unfolding" pre_tac; *)
 	    (* $zeta$ normalizing of the conclusion *)
-	    reduce
+	    Proofview.V82.of_tactic (reduce
 	      (Genredexpr.Cbv
 		 { Redops.all_flags with
 		     Genredexpr.rDelta = false ;
 		     Genredexpr.rConst = []
 		 }
 	      )
-	      Locusops.onConcl;
+	      Locusops.onConcl);
 	    observe_tac ("toto ") tclIDTAC;
     
 	    (* introducing the the result of the graph and the equality hypothesis *)
@@ -389,10 +396,10 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
 	(fun ((_,(ctxt,concl))) ->
 	   match ctxt with
 	     | [] | [_] | [_;_] -> anomaly (Pp.str "bad context")
-	     | hres::res::(x,_,t)::ctxt ->
+	     | hres::res::decl::ctxt ->
 		let res = Termops.it_mkLambda_or_LetIn
 			    (Termops.it_mkProd_or_LetIn concl [hres;res])
-			    ((x,None,t)::ctxt)
+			    (LocalAssum (get_name decl, get_type decl) :: ctxt)
 		in
 		res
 	)
@@ -407,8 +414,8 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
     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
+	  (fun (bindings,avoid) decl p ->
+	     let id = Namegen.next_ident_away (Nameops.out_name (get_name decl)) avoid in
 	     p::bindings,id::avoid
 	  )
 	  ([],pf_ids_of_hyps g)
@@ -417,8 +424,8 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
       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
+	  (fun (bindings,avoid) decl p ->
+	     let id = Namegen.next_ident_away (Nameops.out_name (get_name decl)) avoid in
 	     (nf_zeta p)::bindings,id::avoid)
 	  ([],avoid)
 	  princ_infos.predicates
@@ -454,10 +461,11 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
    generalize every hypothesis which depends of [x] but [hyp]
 *)
 let generalize_dependent_of x hyp g =
+  let open Context.Named.Declaration in
   tclMAP
     (function
-       | (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])
+       | LocalAssum (id,t) when not (Id.equal id hyp) &&
+	   (Termops.occur_var (pf_env g) x t) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id])
        | _ -> tclIDTAC
     )
     (pf_hyps g)
@@ -467,6 +475,15 @@ let generalize_dependent_of x hyp g =
 (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis
        (unfolding, substituting, destructing cases \ldots)
  *)
+let tauto =
+  let dp = List.map Id.of_string ["Tauto" ; "Init"; "Coq"] in
+  let mp = ModPath.MPfile (DirPath.make dp) in
+  let kn = KerName.make2 mp (Label.make "tauto") in
+  Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () ->
+    let body = Tacenv.interp_ltac kn in
+    Tacinterp.eval_tactic body
+  end
+
 let  rec intros_with_rewrite g =
   observe_tac "intros_with_rewrite" intros_with_rewrite_aux g
 and intros_with_rewrite_aux : tactic =
@@ -483,15 +500,15 @@ and intros_with_rewrite_aux : tactic =
 			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) ))
+			Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))]);
+			tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (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) ))
+			Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))]);
+			tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))] ((destVar args.(2)),Locus.InHyp) )))
 			  (pf_ids_of_hyps g);
 			intros_with_rewrite
 		      ] g
@@ -523,7 +540,7 @@ and intros_with_rewrite_aux : tactic =
 			  ] g
 			end
 		  | Ind _ when eq_constr t (Coqlib.build_coq_False ()) ->
-		      Proofview.V82.of_tactic Tauto.tauto g
+		      Proofview.V82.of_tactic tauto g
 		  | Case(_,_,v,_) ->
 		      tclTHENSEQ[
 			Proofview.V82.of_tactic (simplest_case v);
@@ -531,12 +548,12 @@ and intros_with_rewrite_aux : tactic =
 		      ] g
 		  | LetIn _ ->
 		      tclTHENSEQ[
-			reduce
+			Proofview.V82.of_tactic (reduce
 			  (Genredexpr.Cbv
 			     {Redops.all_flags
 			      with Genredexpr.rDelta = false;
 			     })
-			  Locusops.onConcl
+			  Locusops.onConcl)
 			;
 			intros_with_rewrite
 		      ] g
@@ -546,12 +563,12 @@ and intros_with_rewrite_aux : tactic =
 	      end
 	  | LetIn _ ->
 	      tclTHENSEQ[
-		reduce
+		Proofview.V82.of_tactic (reduce
 		  (Genredexpr.Cbv
 		     {Redops.all_flags
 		      with Genredexpr.rDelta = false;
 		     })
-		  Locusops.onConcl
+		  Locusops.onConcl)
 		;
 		intros_with_rewrite
 	      ] g
@@ -568,7 +585,7 @@ let rec reflexivity_with_destruct_cases g =
 	      observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases
 	    ]
         | _ -> Proofview.V82.of_tactic reflexivity
-    with e when Errors.noncritical e -> Proofview.V82.of_tactic reflexivity
+    with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity
   in
   let eq_ind = make_eq () in
   let discr_inject =
@@ -662,10 +679,10 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
     let branches = List.rev princ_infos.branches in
     let intro_pats =
       List.map
-	(fun (_,_,br_type) ->
+	(fun decl ->
 	   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 (get_type decl)))
 	)
 	branches
     in
@@ -691,18 +708,18 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
 	  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
+	  Proofview.V82.of_tactic (reduce
 	    (Genredexpr.Cbv
 	       {Redops.all_flags
 		with Genredexpr.rDelta = false;
 	       })
-	    Locusops.onConcl
+	    Locusops.onConcl)
 	  ;
-	  Simple.generalize (List.map mkVar ids);
+	  Proofview.V82.of_tactic (generalize (List.map mkVar ids));
 	  thin ids
 	]
       else
-        unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))]
+        Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))])
     in
     (* The proof of each branche itself *)
     let ind_number = ref 0 in
@@ -737,7 +754,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
     tclTHENSEQ
       [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]);
 	observe_tac "h_generalize"
-	(Simple.generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]);
+	(Proofview.V82.of_tactic (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" (Proofview.V82.of_tactic (elim false None (mkVar hres,NoBindings) (Some (mkVar graph_principle_id,NoBindings)))))
@@ -920,7 +937,7 @@ let revert_graph kn post_tac hid g =
 		  let f_args,res = Array.chop (Array.length args - 1) args in
 		  tclTHENSEQ
 		    [
-		      Simple.generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])];
+		      Proofview.V82.of_tactic (generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]);
 		      thin [hid];
 		      Proofview.V82.of_tactic (Simple.intro hid);
 		      post_tac hid
@@ -964,7 +981,7 @@ let functional_inversion kn hid fconst f_correct : tactic =
 	  in
 	  tclTHENSEQ[
 	    pre_tac hid;
-	    Simple.generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])];
+	    Proofview.V82.of_tactic (generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]);
 	    thin [hid];
 	    Proofview.V82.of_tactic (Simple.intro hid);
 	    Proofview.V82.of_tactic (Inv.inv FullInversion None (NamedHyp hid));
@@ -981,7 +998,7 @@ let invfun qhyp f  =
   let f =
     match f with
       | ConstRef f -> f
-      | _ -> raise (Errors.UserError("",str "Not a function"))
+      | _ -> raise (CErrors.UserError("",str "Not a function"))
   in
   try
     let finfos = find_Function_infos f in
diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml
index 87d7ca76..de4210af 100644
--- a/plugins/funind/merge.ml
+++ b/plugins/funind/merge.ml
@@ -11,7 +11,7 @@
 open Globnames
 open Tactics
 open Indfun_common
-open Errors
+open CErrors
 open Util
 open Constrexpr
 open Vernacexpr
@@ -19,12 +19,12 @@ open Pp
 open Names
 open Term
 open Vars
-open Context
 open Termops
 open Declarations
 open Glob_term
 open Glob_termops
 open Decl_kinds
+open Context.Rel.Declaration
 
 (** {1 Utilities}  *)
 
@@ -73,7 +73,7 @@ let ident_global_exist id =
     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
+  with e when CErrors.noncritical e -> false
 
 (** [next_ident_fresh id] returns a fresh identifier (ie not linked in
     global env) with base [id]. *)
@@ -135,9 +135,9 @@ 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()) (fst ind1) in
-  List.iter (fun (nm, optcstr, tp) ->
-    print_string (string_of_name nm^":");
-    prconstr tp; print_string "\n")
+  List.iter (fun decl ->
+    print_string (string_of_name (Context.Rel.Declaration.get_name decl) ^ ":");
+    prconstr (get_type decl); print_string "\n")
     ib1.mind_arity_ctxt;
     Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) ind1);
   Array.iteri
@@ -258,27 +258,27 @@ type merge_infos =
       lnk2: int merged_arg array;
 
       (** rec params which remain rec param (ie not linked) *)
-      recprms1: rel_declaration list;
-      recprms2: rel_declaration list;
+      recprms1: Context.Rel.Declaration.t list;
+      recprms2: Context.Rel.Declaration.t list;
       nrecprms1: int;
       nrecprms2: int;
 
       (** rec parms which became non parm (either linked to something
          or because after a rec parm that became non parm) *)
-      otherprms1: rel_declaration list;
-      otherprms2: rel_declaration list;
+      otherprms1: Context.Rel.Declaration.t list;
+      otherprms2: Context.Rel.Declaration.t list;
       notherprms1:int;
       notherprms2:int;
 
       (** args which remain args in merge *)
-      args1:rel_declaration list;
-      args2:rel_declaration list;
+      args1:Context.Rel.Declaration.t list;
+      args2:Context.Rel.Declaration.t list;
       nargs1:int;
       nargs2:int;
 
       (** functional result args *)
-      funresprms1: rel_declaration list;
-      funresprms2: rel_declaration list;
+      funresprms1: Context.Rel.Declaration.t list;
+      funresprms2: Context.Rel.Declaration.t list;
       nfunresprms1:int;
       nfunresprms2:int;
     }
@@ -460,11 +460,12 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
   let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in
   let _ = prstr "\notherprms1:\n" in
   let _ =
-    List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n")
+    List.iter (fun decl -> prstr (string_of_name (get_name decl) ^ " : ");
+			   prconstr (get_type decl); prstr "\n")
     otherprms1 in
   let _ = prstr "\notherprms2:\n" in
   let _ =
-    List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n")
+    List.iter (fun decl -> prstr (string_of_name (get_name decl) ^ " : "); prconstr (get_type decl); prstr "\n")
     otherprms2 in
   {
     ident=id;
@@ -503,19 +504,19 @@ let rec merge_app c1 c2 id1 id2 shift filter_shift_stable =
   let lnk = Array.append shift.lnk1 shift.lnk2 in
   match c1 , c2 with
     | GApp(_,f1, arr1), GApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 ->
-        let _ = prstr "\nICI1!\n";Pp.flush_all() in
+        let _ = prstr "\nICI1!\n" in
         let args = filter_shift_stable lnk (arr1 @ arr2) in
         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 _ = prstr "\nICI2!\n" in
         let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in
         GLetIn(Loc.ghost,nme,bdy,newtrm)
     | _, GLetIn(_,nme,bdy,trm) ->
-        let _ = prstr "\nICI3!\n";Pp.flush_all() in
+        let _ = prstr "\nICI3!\n" in
         let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in
         GLetIn(Loc.ghost,nme,bdy,newtrm)
-    | _ -> let _ = prstr "\nICI4!\n";Pp.flush_all() in
+    | _ -> let _ = prstr "\nICI4!\n" in
            raise NoMerge
 
 let rec merge_app_unsafe c1 c2 shift filter_shift_stable =
@@ -526,14 +527,14 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable =
         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 _ = prstr "\nICI2 '!\n" in
         let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in
         GLetIn(Loc.ghost,nme,bdy,newtrm)
     | _, GLetIn(_,nme,bdy,trm) ->
-        let _ = prstr "\nICI3 '!\n";Pp.flush_all() in
+        let _ = prstr "\nICI3 '!\n" in
         let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in
         GLetIn(Loc.ghost,nme,bdy,newtrm)
-    | _ -> let _ = prstr "\nICI4 '!\n";Pp.flush_all() in raise NoMerge
+    | _ -> let _ = prstr "\nICI4 '!\n" in raise NoMerge
 
 
 
@@ -784,10 +785,10 @@ let merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
 
   let params1 =
     try fst (glob_decompose_prod_n shift.nrecprms1 (List.hd lcstr1))
-    with e when Errors.noncritical e -> [] in
+    with e when CErrors.noncritical e -> [] in
   let params2 =
     try fst (glob_decompose_prod_n shift.nrecprms2 (List.hd lcstr2))
-    with e when Errors.noncritical e -> [] in
+    with e when CErrors.noncritical e -> [] in
 
   let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in
   let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in
@@ -824,9 +825,11 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
   let concl = Constrextern.extern_constr false (Global.env()) Evd.empty concl in
   let arity,_ =
     List.fold_left
-      (fun (acc,env) (nm,_,c) ->
+      (fun (acc,env) decl ->
+        let nm = Context.Rel.Declaration.get_name decl in
+        let c = get_type decl in
         let typ = Constrextern.extern_constr false env Evd.empty c in
-        let newenv = Environ.push_rel (nm,None,c) env in
+        let newenv = Environ.push_rel (LocalAssum (nm,c)) env in
         CProdN (Loc.ghost, [[(Loc.ghost,nm)],Constrexpr_ops.default_binder_kind,typ] , acc) , newenv)
       (concl,Global.env())
       (shift.funresprms2 @ shift.funresprms1
@@ -851,12 +854,12 @@ let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift
   lident , bindlist , Some cstr_expr , lcstor_expr
 
 
-let mkProd_reldecl (rdecl:rel_declaration) (t2:glob_constr) =
+let mkProd_reldecl (rdecl:Context.Rel.Declaration.t) (t2:glob_constr) =
   match rdecl with
-    | (nme,None,t) ->
+    | LocalAssum (nme,t) ->
         let traw = Detyping.detype false [] (Global.env()) Evd.empty t in
         GProd (Loc.ghost,nme,Explicit,traw,t2)
-    | (_,Some _,_) -> assert false
+    | LocalDef _ -> assert false
 
 
 (** [merge_inductive ind1 ind2 lnk] merges two graphs, linking
@@ -970,7 +973,7 @@ let funify_branches relinfo nfuns branch =
       | Rel i -> let reali = i-shift in (reali>=0 && reali<relinfo.nbranches)
       | _ -> false in
   (* FIXME: *)
-  (Anonymous,Some mkProp,mkProp)
+  LocalDef (Anonymous,mkProp,mkProp)
 
 
 let relprinctype_to_funprinctype relprinctype nfuns =
diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml
index 065d0fe5..fa84e4dd 100644
--- a/plugins/funind/recdef.ml
+++ b/plugins/funind/recdef.ml
@@ -16,7 +16,7 @@ open Names
 open Libnames
 open Globnames
 open Nameops
-open Errors
+open CErrors
 open Util
 open Tacticals
 open Tacmach
@@ -29,6 +29,7 @@ open Proof_type
 open Pfedit
 open Glob_term
 open Pretyping
+open Termops
 open Constrintern
 open Misctypes
 open Genredexpr
@@ -38,7 +39,8 @@ open Auto
 open Eauto
 
 open Indfun_common
-
+open Sigma.Notations
+open Context.Rel.Declaration
 
 
 (* Ugly things which should not be here *)
@@ -90,15 +92,15 @@ let const_of_ref = function
 
 
 let nf_zeta env =
-  Reductionops.clos_norm_flags  (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+  Reductionops.clos_norm_flags  (CClosure.RedFlags.mkflags [CClosure.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
+    CClosure.norm_val (CClosure.create_clos_infos flgs env) (CClosure.inject (Reductionops.nf_evar sigma t)) in
+  clos_norm_flags CClosure.betaiotazeta  Environ.empty_env Evd.empty
 
 
 
@@ -159,7 +161,7 @@ let rec n_x_id ids n =
 let simpl_iter clause =
   reduce
     (Lazy
-       {rBeta=true;rIota=true;rZeta= true; rDelta=false;
+       {rBeta=true;rMatch=true;rFix=true;rCofix=true;rZeta=true;rDelta=false;
         rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]})
     clause
 
@@ -179,7 +181,7 @@ let (value_f:constr list -> global_reference -> constr) =
       )
     in
     let context = List.map
-      (fun (x, c) -> Name x, None, c) (List.combine rev_x_id_l (List.rev al))
+      (fun (x, c) -> LocalAssum (Name x, c)) (List.combine rev_x_id_l (List.rev al))
     in
     let env = Environ.push_rel_context context (Global.env ()) in
     let glob_body =
@@ -206,23 +208,23 @@ let (declare_f : Id.t -> logical_kind -> constr list -> global_reference -> glob
 (* Debugging mechanism *)
 let debug_queue = Stack.create ()
 
-let rec print_debug_queue b e = 
+let 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)
+	Feedback.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal))
       else
 	begin
-	  Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal);
+	  Feedback.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal));
 	end;
       (* print_debug_queue false e; *)
     end
 
 let observe strm =
   if do_observe ()
-  then Pp.msg_debug strm
+  then Feedback.msg_debug strm
   else ()
 
 
@@ -236,9 +238,9 @@ let do_observe_tac s tac g =
     ignore(Stack.pop debug_queue);
     v
   with reraise ->
-    let reraise = Errors.push reraise in
+    let reraise = CErrors.push reraise in
     if not (Stack.is_empty debug_queue)
-    then print_debug_queue true (fst (Cerrors.process_vernac_interp_error reraise));
+    then print_debug_queue true (fst (ExplainErr.process_vernac_interp_error reraise));
     iraise reraise
 
 let observe_tac s tac g =
@@ -265,8 +267,8 @@ let observe_tclTHENLIST s tacl =
 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)
+      | None -> tclIDTAC
+      | Some l -> tclMAP (fun id -> tclTRY (Proofview.V82.of_tactic (clear [id]))) (List.rev l)
   in
   observe_tclTHENLIST (str "tclUSER1")
     [
@@ -274,8 +276,8 @@ let tclUSER tac is_mes l g =
       if is_mes
       then observe_tclTHENLIST (str "tclUSER2")
         [
-	  unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference
-            (delayed_force Indfun_common.ltof_ref))];
+	  Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference
+            (delayed_force Indfun_common.ltof_ref))]);
          tac
 	 ]
       else tac
@@ -397,7 +399,7 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic =
 	Proofview.V82.of_tactic (intro_using teq_id);
 	onLastHypId (fun heq -> 
 	  observe_tclTHENLIST (str "treat_case2")[
-	    thin to_intros;
+	    Proofview.V82.of_tactic (clear to_intros);
 	    h_intros to_intros;
 	    (fun g' -> 
 	      let ty_teq = pf_unsafe_type_of g' (mkVar heq) in
@@ -439,7 +441,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) =
 	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 ->
+	with e when CErrors.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
     | Lambda(n,t,b) -> 
@@ -447,7 +449,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) =
 	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 ->
+	with e when CErrors.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) -> 
@@ -558,12 +560,12 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g =
 			       Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|])));
 			       Proofview.V82.of_tactic default_full_auto];
 		   observe_tclTHENLIST (str "destruct_bounds_aux2")[
-		     observe_tac (str "clearing k ") (clear [id]);
+		     observe_tac (str "clearing k ") (Proofview.V82.of_tactic (clear [id]));
 		     h_intros [k;h';def];
-		     observe_tac (str "simple_iter") (simpl_iter Locusops.onConcl);
+		     observe_tac (str "simple_iter") (Proofview.V82.of_tactic (simpl_iter Locusops.onConcl));
 		     observe_tac (str "unfold functional")
-		       (unfold_in_concl[(Locus.OnlyOccurrences [1],
-					 evaluable_of_global_reference infos.func)]);
+		       (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1],
+					 evaluable_of_global_reference infos.func)]));
 		     (
 		       observe_tclTHENLIST (str "test")[
 			 list_rewrite true
@@ -587,7 +589,7 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g =
       | (_,v_bound)::l -> 
       observe_tclTHENLIST (str "destruct_bounds_aux3")[
 	Proofview.V82.of_tactic (simplest_elim (mkVar v_bound));
-	clear [v_bound];
+	Proofview.V82.of_tactic (clear [v_bound]);
 	tclDO 2 (Proofview.V82.of_tactic intro);
 	onNthHypId 1 
 	  (fun p_hyp -> 
@@ -643,7 +645,7 @@ let terminate_letin (na,b,t,e) expr_info continuation_tac info =
       try 
 	check_not_nested (expr_info.f_id::expr_info.forbidden_ids) b;
 	true
-      with e when Errors.noncritical e -> false
+      with e when CErrors.noncritical e -> false
     in
     if forbid 
     then 
@@ -676,8 +678,10 @@ let mkDestructEq :
   let hyps = pf_hyps g in
   let to_revert =
     Util.List.map_filter
-      (fun (id, _, t) ->
-        if Id.List.mem id not_on_hyp || not (Termops.occur_term expr t)
+      (fun decl ->
+        let open Context.Named.Declaration in
+        let id = get_id decl in
+        if Id.List.mem id not_on_hyp || not (Termops.occur_term expr (get_type decl))
         then None else Some id) hyps in
   let to_revert_constr = List.rev_map mkVar to_revert in
   let type_of_expr = pf_unsafe_type_of g expr in
@@ -685,11 +689,13 @@ let mkDestructEq :
            to_revert_constr in
     pf_typel new_hyps (fun _ ->
     observe_tclTHENLIST (str "mkDestructEq")
-     [Simple.generalize new_hyps;
+     [Proofview.V82.of_tactic (generalize new_hyps);
       (fun g2 ->
-	Proofview.V82.of_tactic (change_in_concl None
-	  (fun patvars sigma ->
-	    pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2))) g2);
+        let changefun patvars = { run = fun sigma ->
+          let redfun = pattern_occs [Locus.AllOccurrencesBut [1], expr] in
+          redfun.Reductionops.e_redfun (pf_env g2) sigma (pf_concl g2)
+        } in
+	Proofview.V82.of_tactic (change_in_concl None changefun) g2);
       Proofview.V82.of_tactic (simplest_case expr)]), to_revert
 
 
@@ -698,7 +704,7 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g =
     try
       check_not_nested (expr_info.f_id::expr_info.forbidden_ids) a;
       false
-    with e when Errors.noncritical e ->
+    with e when CErrors.noncritical e ->
       true
   in
   let a' = infos.info in
@@ -897,10 +903,10 @@ let make_rewrite expr_info l hp max =
        [observe_tac(str "make_rewrite finalize") (
 	 (* tclORELSE( h_reflexivity) *)
 	 (observe_tclTHENLIST (str "make_rewrite")[
-	   simpl_iter Locusops.onConcl;
+	   Proofview.V82.of_tactic (simpl_iter Locusops.onConcl);
 	   observe_tac (str "unfold functional")
-	     (unfold_in_concl[(Locus.OnlyOccurrences [1],
-			       evaluable_of_global_reference expr_info.func)]);
+	     (Proofview.V82.of_tactic (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));
@@ -942,7 +948,7 @@ let rec destruct_hex expr_info acc l =
     | (v,hex)::l -> 
       observe_tclTHENLIST (str "destruct_hex")[
 	Proofview.V82.of_tactic (simplest_case (mkVar hex));
-	clear [hex];
+	Proofview.V82.of_tactic (clear [hex]);
 	tclDO 2 (Proofview.V82.of_tactic intro);
 	onNthHypId 1 (fun hp -> 
 	  onNthHypId 2 (fun p -> 
@@ -1110,10 +1116,10 @@ let termination_proof_header is_mes input_type ids args_id relation
 	       [observe_tac (str "generalize")
 		  (onNLastHypsId (nargs+1)
 		     (tclMAP (fun id ->
-			tclTHEN (Tactics.Simple.generalize [mkVar id]) (clear [id]))
+			tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (Proofview.V82.of_tactic (clear [id])))
 		     ))
 	       ;
-		observe_tac (str "fix") (fix (Some hrec) (nargs+1));
+		observe_tac (str "fix") (Proofview.V82.of_tactic (fix (Some hrec) (nargs+1)));
 		h_intros args_id;
 		Proofview.V82.of_tactic (Simple.intro wf_rec_arg);
 		observe_tac (str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv)
@@ -1248,7 +1254,7 @@ let clear_goals =
 	  then Termops.pop b'
 	  else if b' == b then t
 	  else mkProd(na,t',b')
-      | _ -> map_constr clear_goal t
+      | _ -> Term.map_constr clear_goal t
   in
   List.map clear_goal
 
@@ -1275,12 +1281,12 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp
     | Some s -> s
     | None   ->
 	try add_suffix current_proof_name "_subproof"
-	with e when Errors.noncritical e ->
+	with e when CErrors.noncritical e ->
           anomaly (Pp.str "open_new_goal with an unamed theorem")
   in
   let na = next_global_ident_away name [] in
   if Termops.occur_existential gls_type then
-    Errors.error "\"abstract\" cannot handle existentials";
+    CErrors.error "\"abstract\" cannot handle existentials";
   let hook _ _ =
     let opacity =
       let na_ref = Libnames.Ident (Loc.ghost,na) in
@@ -1300,7 +1306,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp
 	   let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in
 	   observe_tclTHENLIST (str "")
 	     [
-	       Simple.generalize [lemma];
+	       Proofview.V82.of_tactic (generalize [lemma]);
 	       Proofview.V82.of_tactic (Simple.intro hid);
 	       (fun g ->
 		  let ids = pf_ids_of_hyps g in
@@ -1327,10 +1333,10 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp
 		      tclFIRST[
 			tclTHEN
 			  (Proofview.V82.of_tactic (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)))
-			  e_assumption;
+			  (Proofview.V82.of_tactic e_assumption);
 		      Eauto.eauto_with_bases
 			(true,5)
-			[Evd.empty,Lazy.force refl_equal]
+			[{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}]
 			[Hints.Hint_db.empty empty_transparent_state false]
 		      ]
 		    )
@@ -1420,7 +1426,7 @@ let start_equation (f:global_reference) (term_f:global_reference)
   let x = n_x_id ids nargs in
   observe_tac (str "start_equation") (observe_tclTHENLIST (str "start_equation") [
     h_intros x;
-    unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)];
+    Proofview.V82.of_tactic (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)))));
@@ -1484,7 +1490,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
   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
+  let env = push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env in
   (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type);  *)
   let ty = interp_type_evars env evd ~impls:rec_impls eq in
   let evm, nf = Evarutil.nf_evars_and_universes !evd in
@@ -1492,7 +1498,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
   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
+  let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> LocalAssum (x,y)) res_vars) env in
   let eq' = nf_zeta env_eq' eq'  in
   let res =
 (*     Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *)
@@ -1510,29 +1516,31 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
   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) ~ctx:(snd (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 =
-    fst (*FIXME*)(interp_constr
-      env_with_pre_rec_args
-      (Evd.from_env env_with_pre_rec_args)
-      r)
+  (* Refresh the global universes, now including those of _F *)
+  let evm = Evd.from_env (Global.env ()) in
+  let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> LocalAssum (x,t)) pre_rec_args) env in
+  let relation, evuctx =
+    interp_constr env_with_pre_rec_args evm r
   in
+  let evm = Evd.from_ctx evuctx 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 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 (Loc.ghost,term_id)] in 
+    let _ = Extraction_plugin.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 ->
+      with e when CErrors.noncritical e ->
 	begin
 	  if do_observe ()
-	  then msg_debug (str "Cannot create equation Lemma " ++ Errors.print e)
-	  else anomaly (Pp.str "Cannot create equation Lemma")
+	  then Feedback.msg_debug (str "Cannot create equation Lemma " ++ CErrors.print e)
+	  else CErrors.errorlabstrm "Cannot create equation Lemma"
+               (str "Cannot create equation lemma." ++ spc () ++ 
+                str "This may be because the function is nested-recursive.")
 	  ;
 	  true
 	end
diff --git a/plugins/funind/recdef_plugin.mllib b/plugins/funind/recdef_plugin.mlpack
index ec1f5436..2b443f2a 100644
--- a/plugins/funind/recdef_plugin.mllib
+++ b/plugins/funind/recdef_plugin.mlpack
@@ -8,4 +8,3 @@ Invfun
 Indfun
 Merge
 G_indfun
-Recdef_plugin_mod
diff --git a/plugins/micromega/Env.v b/plugins/micromega/Env.v
index a19e9df9..7e3ef892 100644
--- a/plugins/micromega/Env.v
+++ b/plugins/micromega/Env.v
@@ -93,7 +93,7 @@ End S.
 Ltac jump_simpl :=
   repeat
     match goal with
-      | |- appcontext [jump xH] => rewrite (jump_simpl xH)
-      | |- appcontext [jump (xO ?p)] => rewrite (jump_simpl (xO p))
-      | |- appcontext [jump (xI ?p)] => rewrite (jump_simpl (xI p))
+      | |- context [jump xH] => rewrite (jump_simpl xH)
+      | |- context [jump (xO ?p)] => rewrite (jump_simpl (xO p))
+      | |- context [jump (xI ?p)] => rewrite (jump_simpl (xI p))
     end.
diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v
index fd4bb248..904ee4da 100644
--- a/plugins/micromega/EnvRing.v
+++ b/plugins/micromega/EnvRing.v
@@ -914,7 +914,7 @@ Qed.
  revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros.
  - discriminate.
  - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst.
-   * injection H; intros <-. rewrite <- PSubstL1_ok; intuition.
+   * injection H as <-. rewrite <- PSubstL1_ok; intuition.
    * now apply IH.
  Qed.
 
diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v
index 3e58e81a..47b6f7c7 100644
--- a/plugins/micromega/Lia.v
+++ b/plugins/micromega/Lia.v
@@ -8,7 +8,7 @@
 (*                                                                      *)
 (* Micromega: A reflexive tactic using the Positivstellensatz           *)
 (*                                                                      *)
-(*  Frédéric Besson (Irisa/Inria)      2013                             *)
+(*  Frédéric Besson (Irisa/Inria)      2013-2016                        *)
 (*                                                                      *)
 (************************************************************************)
 
@@ -16,27 +16,27 @@ Require Import ZMicromega.
 Require Import ZArith.
 Require Import RingMicromega.
 Require Import VarMap.
-Require Tauto.
+Require Coq.micromega.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 zchange := 
+  intros __wit __varmap __ff ;
+  change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+  apply (ZTautoChecker_sound __ff __wit).
+
+Ltac zchecker_no_abstract := zchange ; vm_compute ; reflexivity.
+
+Ltac zchecker_abstract := zchange ; vm_cast_no_check (eq_refl true).
+
+Ltac zchecker := zchecker_no_abstract.
+
+Ltac lia := preprocess; xlia zchecker.
+               
+Ltac nia := preprocess; xnlia zchecker.
 
 
 (* Local Variables: *)
diff --git a/plugins/micromega/Lqa.v b/plugins/micromega/Lqa.v
new file mode 100644
index 00000000..acd2751a
--- /dev/null
+++ b/plugins/micromega/Lqa.v
@@ -0,0 +1,51 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \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)      2016                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import QMicromega.
+Require Import QArith.
+Require Import RingMicromega.
+Require Import VarMap.
+Require Coq.micromega.Tauto.
+Declare ML Module "micromega_plugin".
+
+Ltac rchange := 
+  intros __wit __varmap __ff ;
+  change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
+  apply (QTautoChecker_sound __ff __wit).
+
+Ltac rchecker_no_abstract := rchange ; vm_compute ; reflexivity.
+Ltac rchecker_abstract   := rchange ; vm_cast_no_check (eq_refl true).
+
+Ltac rchecker := rchecker_no_abstract.
+
+(** Here, lra stands for linear rational arithmetic *)
+Ltac lra := lra_Q  rchecker.
+
+(** Here, nra stands for non-linear rational arithmetic *)
+Ltac nra := xnqa  rchecker.
+
+Ltac xpsatz dom d :=
+  let tac := lazymatch dom with
+  | Q =>
+    ((sos_Q rchecker) || (psatz_Q d rchecker))
+  | _ => fail "Unsupported domain"
+  end in tac.
+
+Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n.
+Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1).
+
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/Lra.v b/plugins/micromega/Lra.v
new file mode 100644
index 00000000..5b97d8ed
--- /dev/null
+++ b/plugins/micromega/Lra.v
@@ -0,0 +1,52 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \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)      2016                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import RMicromega.
+Require Import QMicromega.
+Require Import Rdefinitions.
+Require Import RingMicromega.
+Require Import VarMap.
+Require Coq.micromega.Tauto.
+Declare ML Module "micromega_plugin".
+
+Ltac rchange := 
+  intros __wit __varmap __ff ;
+  change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
+  apply (RTautoChecker_sound __ff __wit).
+
+Ltac rchecker_no_abstract := rchange ; vm_compute ; reflexivity.
+Ltac rchecker_abstract   := rchange ; vm_cast_no_check (eq_refl true).
+
+Ltac rchecker := rchecker_no_abstract.
+
+(** Here, lra stands for linear real arithmetic *)
+Ltac lra := unfold Rdiv in * ;   lra_R  rchecker.
+
+(** Here, nra stands for non-linear real arithmetic *)
+Ltac nra := unfold Rdiv in * ; xnra  rchecker.
+
+Ltac xpsatz dom d :=
+  let tac := lazymatch dom with
+  | R =>
+    (sos_R rchecker) || (psatz_R d rchecker)
+  | _ => fail "Unsupported domain"
+ end in tac.
+
+Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n.
+Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1).
+
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v
index 0a41af45..d28bb828 100644
--- a/plugins/micromega/MExtraction.v
+++ b/plugins/micromega/MExtraction.v
@@ -50,7 +50,7 @@ Extract Constant Rinv   => "fun x -> 1 / x".
 
 Extraction "micromega.ml"
   List.map simpl_cone (*map_cone  indexes*)
-  denorm Qpower
+  denorm Qpower vm_add
   n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find.
 
 
diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v
index a461b26a..8acf0ff8 100644
--- a/plugins/micromega/Psatz.v
+++ b/plugins/micromega/Psatz.v
@@ -8,7 +8,7 @@
 (*                                                                      *)
 (* Micromega: A reflexive tactic using the Positivstellensatz           *)
 (*                                                                      *)
-(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2016                             *)
 (*                                                                      *)
 (************************************************************************)
 
@@ -20,75 +20,36 @@ Require Import ZArith.
 Require Import Rdefinitions.
 Require Import RingMicromega.
 Require Import VarMap.
-Require Tauto.
-Declare ML Module "micromega_plugin".
+Require Coq.micromega.Tauto.
+Require Lia.
+Require Lra.
+Require Lqa.
 
-Ltac preprocess := 
-    zify ; unfold Z.succ in * ; unfold Z.pred in *.
+Declare ML Module "micromega_plugin".
 
-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 lia := Lia.lia.
 
-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 nia := Lia.nia.
 
 
 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_cast_no_check (eq_refl true))
+    (sos_Z Lia.zchecker) || (psatz_Z d  Lia.zchecker)
   | 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 (abstract(intros __wit __varmap __ff ;
-        change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
-        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  (abstract(intros __wit __varmap __ff ;
-        change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
-        apply (QTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)))
+    (sos_R Lra.rchecker) || (psatz_R d Lra.rchecker)
+  | Q => (sos_Q Lqa.rchecker) || (psatz_Q d Lqa.rchecker) 
   | _ => fail "Unsupported domain"
   end in tac.
 
 Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n.
-Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:-1.
+Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1).
 
 Ltac psatzl dom :=
   let tac := lazymatch dom with
-  | 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 (abstract(intros __wit __varmap __ff ;
-        change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
-        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 abstract((intros __wit __varmap __ff ;
-        change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
-        apply (RTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)))
+  | Z => Lia.lia
+  | Q => Lqa.lra
+  | R => Lra.lra
   | _ => fail "Unsupported domain"
   end in tac.
 
@@ -96,6 +57,8 @@ Ltac psatzl dom :=
 Ltac lra := 
   first [ psatzl R | psatzl Q ].
 
+Ltac nra := 
+  first [ Lra.nra | Lqa.nra ].  
 
 
 (* Local Variables: *)
diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v
index 43268363..b13285f5 100644
--- a/plugins/micromega/QMicromega.v
+++ b/plugins/micromega/QMicromega.v
@@ -168,7 +168,7 @@ Proof.
   exact H.
 Qed.
 
-Require Import Tauto.
+Require Import Coq.micromega.Tauto.
 
 Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool.
 Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool.
diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v
index 72353a99..2352d78d 100644
--- a/plugins/micromega/RMicromega.v
+++ b/plugins/micromega/RMicromega.v
@@ -533,7 +533,7 @@ Proof.
   exact H.
 Qed.
 
-Require Import Tauto.
+Require Import Coq.micromega.Tauto.
 
 Definition Rnormalise := @cnf_normalise Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool.
 Definition Rnegate := @cnf_negate Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool.
diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v
index 751a81df..ed49c3df 100644
--- a/plugins/micromega/RingMicromega.v
+++ b/plugins/micromega/RingMicromega.v
@@ -794,7 +794,7 @@ Definition xnormalise (t:Formula C) : list (NFormula)  :=
       | OpLe => (psub lhs rhs ,Strict) :: nil
     end.
 
-Require Import Tauto.
+Require Import Coq.micromega.Tauto.
 
 Definition cnf_normalise (t:Formula C) : cnf (NFormula) :=
   List.map  (fun x => x::nil) (xnormalise t).
diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v
index 4981ddb3..2d2c0bc7 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-2016     *)
+(* <O___,, *   INRIA - CNRS - 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,6 +26,7 @@ Set Implicit Arguments.
  *)
 
 Section MakeVarMap.
+  
   Variable A : Type.
   Variable default : A.
 
@@ -46,5 +47,29 @@ Section MakeVarMap.
     end.
 
 
-End MakeVarMap.
+  Fixpoint singleton (x:positive) (v : A) : t :=
+    match x with
+    | xH => Leaf v
+    | xO p => Node (singleton p v) default Empty
+    | xI p => Node Empty default (singleton p v)
+    end.
+  
+  Fixpoint vm_add (x: positive) (v : A) (m : t) {struct m} : t :=
+    match m with
+    | Empty   => singleton x v
+    | Leaf vl =>
+      match x with
+      | xH => Leaf v
+      | xO p => Node (singleton p v) vl Empty
+      | xI p => Node Empty vl (singleton p v)
+      end
+    | Node l o r => 
+      match x with
+      | xH => Node l v r
+      | xI p => Node l o (vm_add p v r)
+      | xO p => Node (vm_add p v l) o r
+      end
+    end.
 
+  
+End MakeVarMap.  
diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v
index d7ddef2b..5aa8d03f 100644
--- a/plugins/micromega/ZMicromega.v
+++ b/plugins/micromega/ZMicromega.v
@@ -198,7 +198,7 @@ Definition xnormalise (t:Formula Z) : list (NFormula Z)  :=
       | OpLe => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil
     end.
 
-Require Import Tauto BinNums.
+Require Import Coq.micromega.Tauto BinNums.
 
 Definition normalise (t:Formula Z) : cnf (NFormula Z) :=
   List.map  (fun x => x::nil) (xnormalise t).
diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml
index a5fceb56..459c72f9 100644
--- a/plugins/micromega/certificate.ml
+++ b/plugins/micromega/certificate.ml
@@ -63,82 +63,82 @@ let r_spec = z_spec
 let dev_form n_spec  p =
  let rec dev_form p = 
   match p with
-   | Mc.PEc z ->  Poly.constant (n_spec.number_to_num z)
-   | Mc.PEX v ->  Poly.variable (C2Ml.positive v)
-   | Mc.PEmul(p1,p2) -> 
-      let p1 = dev_form p1 in
-      let p2 = dev_form p2 in
-       Poly.product p1 p2 
-   | Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2)
-   | Mc.PEopp p ->  Poly.uminus (dev_form p)
-   | Mc.PEsub(p1,p2) ->  Poly.addition (dev_form p1) (Poly.uminus (dev_form p2))
-   | Mc.PEpow(p,n)   ->  
-      let p = dev_form p in
-      let n = C2Ml.n n in
-      let rec pow n = 
-       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
-  dev_form p
+  | Mc.PEc z ->  Poly.constant (n_spec.number_to_num z)
+  | Mc.PEX v ->  Poly.variable (C2Ml.positive v)
+  | Mc.PEmul(p1,p2) -> 
+   let p1 = dev_form p1 in
+   let p2 = dev_form p2 in
+   Poly.product p1 p2 
+  | Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2)
+  | Mc.PEopp p ->  Poly.uminus (dev_form p)
+  | Mc.PEsub(p1,p2) ->  Poly.addition (dev_form p1) (Poly.uminus (dev_form p2))
+  | Mc.PEpow(p,n)   ->  
+   let p = dev_form p in
+   let n = C2Ml.n n in
+   let rec pow n = 
+    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
+ dev_form p
 
 
 let monomial_to_polynomial mn = 
  Monomial.fold 
   (fun v i acc -> 
-     let v = Ml2C.positive v in
-     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 
-   (Mc.PEc (Mc.Zpos Mc.XH))
+   let v = Ml2C.positive v in
+   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 
+  (Mc.PEc (Mc.Zpos Mc.XH))
   
 
 
 let list_to_polynomial vars l = 
  assert (List.for_all (fun x -> ceiling_num x =/ x) l);
  let var x = monomial_to_polynomial (List.nth vars x)  in
-       
+ 
  let rec xtopoly p i = function
   | [] -> p
   | 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 Pervasives.(=) c (Mc.PEc (Mc.Zpos Mc.XH))
-     then var i
-     else Mc.PEmul (c,var i) in
-    let p' = if Pervasives.(=) p (Mc.PEc Mc.Z0) then mn else
-      Mc.PEadd (mn, p) in
-     xtopoly p' (i+1) l in
-  
-  xtopoly (Mc.PEc Mc.Z0) 0 l
+   else let c = Mc.PEc (Ml2C.bigint (numerator c)) in
+        let mn = 
+         if Pervasives.(=) c (Mc.PEc (Mc.Zpos Mc.XH))
+         then var i
+         else Mc.PEmul (c,var i) in
+        let p' = if Pervasives.(=) p (Mc.PEc Mc.Z0) then mn else
+          Mc.PEadd (mn, p) in
+        xtopoly p' (i+1) l in
+ 
+ xtopoly (Mc.PEc Mc.Z0) 0 l
 
 let rec fixpoint f x =
  let y' = f x in
-  if Pervasives.(=) y' x then y'
-  else fixpoint f y'
+ if Pervasives.(=) y' x then y'
+ else fixpoint f y'
 
 let  rec_simpl_cone n_spec e = 
  let simpl_cone = 
   Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in
 
  let rec rec_simpl_cone  = function
- | Mc.PsatzMulE(t1, t2) -> 
-    simpl_cone  (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2))
- | Mc.PsatzAdd(t1,t2)  -> 
-    simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2))
- |  x           -> simpl_cone x in
-  rec_simpl_cone e
-   
-   
+  | Mc.PsatzMulE(t1, t2) -> 
+   simpl_cone  (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2))
+  | Mc.PsatzAdd(t1,t2)  -> 
+   simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2))
+  |  x           -> simpl_cone x in
+ rec_simpl_cone e
+  
+  
 let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c
  
 type cone_prod = 
-  Const of cone 
-  | Ideal of cone *cone 
-  | Mult of cone * cone 
-  | Other of cone
+ Const of cone 
+| Ideal of cone *cone 
+| Mult of cone * cone 
+| Other of cone
 and cone =   Mc.zWitness
 
 
@@ -147,32 +147,32 @@ let factorise_linear_cone c =
  
  let rec cone_list  c l = 
   match c with
-   | Mc.PsatzAdd (x,r) -> cone_list  r (x::l)
-   |  _        ->  c :: l in
-  
+  | Mc.PsatzAdd (x,r) -> cone_list  r (x::l)
+  |  _        ->  c :: l in
+ 
  let factorise c1 c2 =
   match c1 , c2 with
-   | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') -> 
-      if Pervasives.(=) x x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None
-   | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') -> 
-      if Pervasives.(=) x x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None
-   |  _     -> None in
-  
+  | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') -> 
+   if Pervasives.(=) x x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None
+  | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') -> 
+   if Pervasives.(=) x x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None
+  |  _     -> None in
+ 
  let rec rebuild_cone l pending  =
   match l with
-   | [] -> (match pending with
-      | None -> Mc.PsatzZ
-      | Some p -> p
-     )
-   | e::l -> 
-      (match pending with
-       | None -> rebuild_cone l (Some e) 
-       | Some p -> (match factorise p e with
-          | None -> Mc.PsatzAdd(p, rebuild_cone l (Some e))
-          | Some f -> rebuild_cone l (Some f) )
-      ) in
+  | [] -> (match pending with
+   | None -> Mc.PsatzZ
+   | Some p -> p
+  )
+  | e::l -> 
+   (match pending with
+   | None -> rebuild_cone l (Some e) 
+   | Some p -> (match factorise p e with
+    | None -> Mc.PsatzAdd(p, rebuild_cone l (Some e))
+    | Some f -> rebuild_cone l (Some f) )
+   ) in
 
-  (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None)
+ (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None)
 
 
 
@@ -199,28 +199,28 @@ open Mfourier
 
 let constrain_monomial mn l  = 
  let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in
-  if Pervasives.(=) mn Monomial.const
-  then  
-   { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; 
-     op = Eq ; 
-     cst = Big_int zero_big_int  }
-  else
-   { coeffs = Vect.from_list ((Big_int zero_big_int):: (List.rev coeffs)) ; 
-     op = Eq ; 
-     cst = Big_int zero_big_int  }
+ if Pervasives.(=) mn Monomial.const
+ then  
+  { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; 
+    op = Eq ; 
+    cst = Big_int zero_big_int  }
+ else
+  { coeffs = Vect.from_list ((Big_int zero_big_int):: (List.rev coeffs)) ; 
+    op = Eq ; 
+    cst = Big_int zero_big_int  }
 
-    
+   
 let positivity l = 
  let rec xpositivity i l = 
   match l with
-   | [] -> []
-   | (_,Mc.Equal)::l -> xpositivity (i+1) l
-   | (_,_)::l -> 
-      {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; 
-       op = Ge ; 
-       cst = Int 0 }  :: (xpositivity (i+1) l)
+  | [] -> []
+  | (_,Mc.Equal)::l -> xpositivity (i+1) l
+  | (_,_)::l -> 
+   {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; 
+    op = Ge ; 
+    cst = Int 0 }  :: (xpositivity (i+1) l)
  in
-  xpositivity 0 l
+ xpositivity 0 l
 
 
 let string_of_op = function
@@ -241,23 +241,23 @@ let build_linear_system l =
 
  let monomials = 
   List.fold_left (fun acc p -> 
-                    Poly.fold (fun m _ acc -> MonSet.add m acc) p acc) 
-    (MonSet.singleton Monomial.const) l'
+   Poly.fold (fun m _ acc -> MonSet.add m acc) p acc) 
+   (MonSet.singleton Monomial.const) l'
  in  (* For each monomial, compute a constraint *)
  let s0 = 
   MonSet.fold (fun mn  res -> (constrain_monomial mn l')::res) monomials [] in
-  (* I need at least something strictly positive *)
+ (* I need at least something strictly positive *)
  let strict = {
   coeffs = Vect.from_list ((Big_int unit_big_int)::
                             (List.map (fun (x,y) -> 
-                              match y with Mc.Strict -> 
-                                  Big_int unit_big_int 
-                              | _ -> Big_int zero_big_int) l));
+                             match y with Mc.Strict -> 
+                              Big_int unit_big_int 
+                             | _ -> Big_int zero_big_int) l));
   op = Ge ; cst = Big_int unit_big_int } in
   (* Add the positivity constraint *)
-  {coeffs = Vect.from_list ([Big_int unit_big_int]) ; 
-   op = Ge ; 
-   cst = Big_int zero_big_int}::(strict::(positivity l)@s0)
+ {coeffs = Vect.from_list ([Big_int unit_big_int]) ; 
+  op = Ge ; 
+  cst = Big_int zero_big_int}::(strict::(positivity l)@s0)
 
 
 let big_int_to_z = Ml2C.bigint
@@ -266,32 +266,32 @@ let big_int_to_z = Ml2C.bigint
    -- at a lower layer, certificates are using nums... *)
 let make_certificate n_spec (cert,li) = 
  let bint_to_cst = n_spec.bigint_to_number in
-  match cert with
-   | [] -> failwith "empty_certificate"
-   | e::cert' -> 
-(*      let cst = match compare_big_int e zero_big_int with
-       | 0 -> Mc.PsatzZ
-       | 1 ->  Mc.PsatzC (bint_to_cst e) 
-       | _ -> failwith "positivity error" 
-      in *)
-      let rec scalar_product cert l =
-       match cert with
-        | [] -> Mc.PsatzZ
-        | c::cert -> 
-	    match l with
-              | [] -> failwith "make_certificate(1)"
-              | i::l ->  
-		  let r = scalar_product cert l in
-		    match compare_big_int c  zero_big_int with
-                      | -1 -> Mc.PsatzAdd (
-			  Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), 
-			  r)
-                      | 0  -> r
-                      | _ ->  Mc.PsatzAdd (
-			  Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)),
-			  r) in
-        (factorise_linear_cone 
-             (simplify_cone n_spec (scalar_product cert' li)))
+ match cert with
+ | [] -> failwith "empty_certificate"
+ | e::cert' -> 
+      (*      let cst = match compare_big_int e zero_big_int with
+              | 0 -> Mc.PsatzZ
+              | 1 ->  Mc.PsatzC (bint_to_cst e) 
+              | _ -> failwith "positivity error" 
+              in *)
+  let rec scalar_product cert l =
+   match cert with
+   | [] -> Mc.PsatzZ
+   | c::cert -> 
+    match l with
+    | [] -> failwith "make_certificate(1)"
+    | i::l ->  
+     let r = scalar_product cert l in
+     match compare_big_int c  zero_big_int with
+     | -1 -> Mc.PsatzAdd (
+      Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), 
+      r)
+     | 0  -> r
+     | _ ->  Mc.PsatzAdd (
+      Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)),
+      r) in
+  (factorise_linear_cone 
+    (simplify_cone n_spec (scalar_product cert' li)))
 
 
 exception Found of Monomial.t
@@ -301,92 +301,155 @@ exception Strict
 module MonMap = Map.Make(Monomial)
 
 let primal l = 
-  let vr = ref 0 in
-
-  let vect_of_poly map p =
-    Poly.fold (fun mn vl (map,vect) -> 
-      if Pervasives.(=) mn Monomial.const 
-      then (map,vect)
-      else 
-	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 vr = ref 0 in
+
+ let vect_of_poly map p =
+  Poly.fold (fun mn vl (map,vect) -> 
+   if Pervasives.(=) mn Monomial.const 
+   then (map,vect)
+   else 
+    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 = Int.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
+ 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 (MonMap.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 ; *)
-    
+ (*  List.iter (fun (p,op) -> Printf.fprintf stdout "%a %s 0\n" Poly.pp p (string_of_op op) ) l ; *)
+ 
  let sys = build_linear_system l in
 
-   try 
-   match Fourier.find_point sys with
-    | Inr _ -> None
-    | 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);
-         flush stdout) ;
-   None
+ try 
+  match Fourier.find_point sys with
+  | Inr _ -> None
+  | Inl cert ->  Some (rats_to_ints (Vect.to_list cert)) 
+  (* should not use rats_to_ints *)
+ with x when CErrors.noncritical x ->
+  if debug
+  then (Printf.printf "raw certificate %s" (Printexc.to_string x);
+        flush stdout) ;
+  None
 
 
 let raw_certificate l = 
-  try 
-    let p = primal l in
-      match Fourier.find_point p with
-	| Inr prf -> 
-	    if debug then Printf.printf "AProof : %a\n" pp_proof prf ; 
-	    let cert = List.map (fun (x,n) -> x+1,n) (fst (List.hd (Proof.mk_proof p prf))) in
-	      if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; 
-	      Some (rats_to_ints (Vect.to_list cert))
-	| Inl _   -> None
-  with Strict -> 
+ try 
+  let p = primal l in
+  match Fourier.find_point p with
+  | Inr prf -> 
+   if debug then Printf.printf "AProof : %a\n" pp_proof prf ; 
+   let cert = List.map (fun (x,n) -> x+1,n) (fst (List.hd (Proof.mk_proof p prf))) in
+   if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; 
+   Some (rats_to_ints (Vect.to_list cert))
+  | Inl _   -> None
+ with Strict -> 
     (* Fourier elimination should handle > *)
-    dual_raw_certificate l 
+  dual_raw_certificate l 
 
 
 let simple_linear_prover  l =
  let (lc,li) = List.split l in
-  match raw_certificate lc with
-   |  None -> None (* No certificate *)
-   | Some cert -> Some (cert,li)
-      
+ match raw_certificate lc with
+ |  None -> None (* No certificate *)
+ | Some cert -> Some (cert,li)
+  
 
 
 
 
 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 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"
-           |  y -> ((dev_form n_spec x, y),i)) l' in
-  let l' = build_system n_spec l in 
-    simple_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 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"
+   |  y -> ((dev_form n_spec x, y),i)) l' in
+ let l' = build_system n_spec l in 
+ simple_linear_prover (*n_spec*) l' 
 
 
 let linear_prover n_spec l  =
  try linear_prover n_spec l
- with x when Errors.noncritical x ->
-   (print_string (Printexc.to_string x); None)
+ with x when CErrors.noncritical x ->
+  (print_string (Printexc.to_string x); None)
+
+let compute_max_nb_cstr l d =
+ let len = List.length l in
+ max len (max d (len * d)) 
+
+let linear_prover_with_cert prfdepth spec  l = 
+ max_nb_cstr := compute_max_nb_cstr l prfdepth ;
+ match linear_prover spec l with
+ | None -> None
+ | Some cert -> Some (make_certificate spec cert)
+
+let nlinear_prover prfdepth (sys: (Mc.q Mc.pExpr * Mc.op1) list) = 
+ LinPoly.MonT.clear ();
+ max_nb_cstr := compute_max_nb_cstr sys prfdepth ;
+ (* Assign a proof to the initial hypotheses *)
+ let sys  = mapi (fun c i -> (c,Mc.PsatzIn (Ml2C.nat i))) sys in
+
+
+ (* Add all the product of hypotheses *)
+ let prod = all_pairs (fun ((c,o),p) ((c',o'),p') -> 
+  ((Mc.PEmul(c,c') , Mc.opMult o o') , Mc.PsatzMulE(p,p'))) sys in
+
+ (* Only filter those have a meaning *)
+ let prod = List.fold_left (fun l ((c,o),p) -> 
+  match o with
+  | None -> l
+  | Some o -> ((c,o),p) :: l) [] prod in
+
+ let sys = sys @ prod in
+
+ let square = 
+  (* Collect the squares and state that they are positive *)
+  let pols = List.map (fun ((p,_),_) -> dev_form q_spec p) sys in
+  let square = 
+   List.fold_left (fun acc p -> 
+    Poly.fold 
+     (fun m _ acc -> 
+      match Monomial.sqrt m with
+      | None -> acc
+      | Some s -> MonMap.add  s m acc)  p acc) MonMap.empty pols in
 
-let linear_prover_with_cert spec l = 
-  match linear_prover spec l with
-    | None -> None
-    | Some cert -> Some (make_certificate spec cert)
+  let pol_of_mon m =
+   Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc q_spec.unit) in
+
+  let norm0 =
+   Mc.norm q_spec.zero q_spec.unit Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool in
+  
+  
+  MonMap.fold (fun s m acc -> ((pol_of_mon m , Mc.NonStrict), Mc.PsatzSquare(norm0 (pol_of_mon s)))::acc) square [] in
+
+ let sys = sys @ square in
 
 
+ (* Call the linear prover without the proofs *)
+ let sys_no_prf = List.map fst sys in
+
+ match linear_prover q_spec sys_no_prf with
+ | None -> None
+ | Some cert -> 
+  let cert = make_certificate q_spec cert in
+  let rec map_psatz = function
+   | Mc.PsatzIn n        -> snd (List.nth sys (C2Ml.nat n))
+   | Mc.PsatzSquare c    -> Mc.PsatzSquare c
+   | Mc.PsatzMulC(c,p)   -> Mc.PsatzMulC(c, map_psatz p)
+   | Mc.PsatzMulE(p1,p2) -> Mc.PsatzMulE(map_psatz p1,map_psatz p2)
+   | Mc.PsatzAdd(p1,p2)  -> Mc.PsatzAdd(map_psatz p1,map_psatz p2)
+   | Mc.PsatzC c         -> Mc.PsatzC c
+   | Mc.PsatzZ           -> Mc.PsatzZ in
+  Some (map_psatz cert)
+
 
 
 let make_linear_system l =
@@ -395,11 +458,11 @@ let make_linear_system l =
   (Poly.constant (Int 0)) l' in
  let monomials = Poly.fold 
   (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 ; 
-    cst = minus_num ( (Poly.get Monomial.const c))}) l
-    ,monomials)
+ (List.map (fun (c,op) -> 
+  {coeffs = Vect.from_list (List.map (fun mn ->  (Poly.get mn c)) monomials) ; 
+   op = op ; 
+   cst = minus_num ( (Poly.get Monomial.const c))}) l
+   ,monomials)
 
 
 let pplus x y = Mc.PEadd(x,y)
@@ -413,7 +476,7 @@ let rec mem p x  l =
 
 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) 
+   remove_assoc p x l else e::(remove_assoc p x l) 
 
 let eq x y = Int.equal (Vect.compare x y) 0
 
@@ -424,39 +487,39 @@ let  remove e  l  = List.fold_left (fun l x -> if eq x e then l else x::l) [] l
    only searching for naive cutting planes *)
 
 let develop_constraint z_spec (e,k) = 
-    match k with
-      | Mc.NonStrict -> (dev_form z_spec e , Ge)
-      | Mc.Equal     ->  (dev_form z_spec e , Eq)
-      | _     -> assert false
+ match k with
+ | Mc.NonStrict -> (dev_form z_spec e , Ge)
+ | Mc.Equal     ->  (dev_form z_spec e , Eq)
+ | _     -> assert false
 
 
 let op_of_op_compat = function
-  | Ge -> Mc.NonStrict
-  | Eq -> Mc.Equal
+ | Ge -> Mc.NonStrict
+ | Eq -> Mc.Equal
 
 
 let integer_vector coeffs = 
-  let vars , coeffs = List.split coeffs in
-    List.combine vars (List.map (fun x -> Big_int x) (rats_to_ints coeffs))
+ let vars , coeffs = List.split coeffs in
+ List.combine vars (List.map (fun x -> Big_int x) (rats_to_ints coeffs))
 
 let integer_cstr {coeffs = coeffs ; op = op ; cst = cst } = 
-  let vars , coeffs = List.split coeffs in
-  match rats_to_ints (cst::coeffs) with
-    | cst :: coeffs -> 
-	{
-	  coeffs = List.combine vars (List.map (fun x -> Big_int x) coeffs) ;
-	  op = op ; cst = Big_int cst}
-    |  _ -> assert false
-	 
+ let vars , coeffs = List.split coeffs in
+ match rats_to_ints (cst::coeffs) with
+ | cst :: coeffs -> 
+  {
+   coeffs = List.combine vars (List.map (fun x -> Big_int x) coeffs) ;
+   op = op ; cst = Big_int cst}
+ |  _ -> assert false
+  
 
 let pexpr_of_cstr_compat var cstr  = 
-  let {coeffs = coeffs ; op = op ; cst = cst } = integer_cstr cstr in
-  try 
-    let expr = list_to_polynomial var (Vect.to_list coeffs) in  
-    let d = Ml2C.bigint (denominator cst) in
-    let n = Ml2C.bigint (numerator cst) in
-      (pplus (pmult (pconst d) expr) (popp (pconst n)), op_of_op_compat op)
-  with Failure _ -> failwith "pexpr_of_cstr_compat"
+ let {coeffs = coeffs ; op = op ; cst = cst } = integer_cstr cstr in
+ try 
+  let expr = list_to_polynomial var (Vect.to_list coeffs) in  
+  let d = Ml2C.bigint (denominator cst) in
+  let n = Ml2C.bigint (numerator cst) in
+  (pplus (pmult (pconst d) expr) (popp (pconst n)), op_of_op_compat op)
+ with Failure _ -> failwith "pexpr_of_cstr_compat"
 
 
 
@@ -465,41 +528,41 @@ open Sos_types
 
 let rec scale_term t = 
  match t with
-  | Zero    -> unit_big_int , Zero
-  | Const n ->  (denominator n) , Const (Big_int (numerator n))
-  | Var n   -> unit_big_int , Var n
-  | Inv _   -> failwith "scale_term : not implemented"
-  | Opp t   -> let s, t = scale_term t in s, Opp t
-  | Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 in
-    let g = gcd_big_int s1 s2 in
-    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 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))
-  | Sub _ -> failwith "scale term: not implemented"
-  | Mul(y,z) ->       let s1,y1 = scale_term y and s2,y2 = scale_term z in
-		       mult_big_int s1 s2 , Mul (y1, y2)
-  |  Pow(t,n) -> let s,t = scale_term t in
-		  power_big_int_positive_int s  n , Pow(t,n)
-  |   _ -> failwith "scale_term : not implemented"
+ | Zero    -> unit_big_int , Zero
+ | Const n ->  (denominator n) , Const (Big_int (numerator n))
+ | Var n   -> unit_big_int , Var n
+ | Inv _   -> failwith "scale_term : not implemented"
+ | Opp t   -> let s, t = scale_term t in s, Opp t
+ | Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 in
+                 let g = gcd_big_int s1 s2 in
+                 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 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))
+ | Sub _ -> failwith "scale term: not implemented"
+ | Mul(y,z) ->       let s1,y1 = scale_term y and s2,y2 = scale_term z in
+		     mult_big_int s1 s2 , Mul (y1, y2)
+ |  Pow(t,n) -> let s,t = scale_term t in
+		power_big_int_positive_int s  n , Pow(t,n)
+ |   _ -> failwith "scale_term : not implemented"
 
 let scale_term t =
  let (s,t') = scale_term t in
-  s,t'
+ s,t'
 
 
 let get_index_of_ith_match f i l  =
  let rec get j res l =
   match l with
-   | [] -> failwith "bad index"
-   | e::l -> if f e
-     then 
-       (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
+  | [] -> failwith "bad index"
+  | e::l -> if f e
+   then 
+    (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
 
 
 let rec scale_certificate pos = match pos with
@@ -511,97 +574,97 @@ let rec scale_certificate pos = match pos with
  | Rational_le n ->  (denominator n) , Rational_le (Big_int (numerator n))
  | Rational_lt n ->  (denominator n) , Rational_lt (Big_int (numerator n))
  | Square t -> let s,t' =  scale_term t in 
-		mult_big_int s s , Square t'
+	       mult_big_int s s , Square t'
  | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in
-		    mult_big_int s1 s2 , Eqmul (y1,y2)
+		   mult_big_int s1 s2 , Eqmul (y1,y2)
  | Sum (y, z) -> let s1,y1 = scale_certificate y 
-   and s2,y2 = scale_certificate z in
-   let g = gcd_big_int s1 s2 in
-   let s1' = div_big_int s1 g in
-   let s2' = div_big_int s2 g in
-    mult_big_int g (mult_big_int s1' s2'), 
-    Sum (Product(Rational_le (Big_int s2'), y1),
-	Product (Rational_le (Big_int s1'), y2))
+ and s2,y2 = scale_certificate z in
+                 let g = gcd_big_int s1 s2 in
+                 let s1' = div_big_int s1 g in
+                 let s2' = div_big_int s2 g in
+                 mult_big_int g (mult_big_int s1' s2'), 
+                 Sum (Product(Rational_le (Big_int s2'), y1),
+	              Product (Rational_le (Big_int s1'), y2))
  | Product (y, z) -> 
-    let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in
-     mult_big_int s1 s2 , Product (y1,y2)
+  let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in
+  mult_big_int s1 s2 , Product (y1,y2)
 
 
 open Micromega
- let rec term_to_q_expr = function
-  | Const n ->  PEc (Ml2C.q n)
-  | Zero   ->  PEc ( Ml2C.q (Int 0))
-  | Var s   ->  PEX (Ml2C.index 
-		      (int_of_string (String.sub s 1 (String.length s - 1))))
-  | Mul(p1,p2) ->  PEmul(term_to_q_expr p1, term_to_q_expr p2)
-  | Add(p1,p2) ->   PEadd(term_to_q_expr p1, term_to_q_expr p2)
-  | Opp p ->   PEopp (term_to_q_expr p)
-  | Pow(t,n) ->  PEpow (term_to_q_expr t,Ml2C.n n)
-  | Sub(t1,t2) ->  PEsub (term_to_q_expr t1,  term_to_q_expr t2)
-  | _ -> failwith "term_to_q_expr: not implemented"
-
- let term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus  Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e)
-
-
- let rec product l = 
-   match l with
-     | [] -> Mc.PsatzZ
-     | [i] -> Mc.PsatzIn (Ml2C.nat i)
-     | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l)
+let rec term_to_q_expr = function
+ | Const n ->  PEc (Ml2C.q n)
+ | Zero   ->  PEc ( Ml2C.q (Int 0))
+ | Var s   ->  PEX (Ml2C.index 
+		     (int_of_string (String.sub s 1 (String.length s - 1))))
+ | Mul(p1,p2) ->  PEmul(term_to_q_expr p1, term_to_q_expr p2)
+ | Add(p1,p2) ->   PEadd(term_to_q_expr p1, term_to_q_expr p2)
+ | Opp p ->   PEopp (term_to_q_expr p)
+ | Pow(t,n) ->  PEpow (term_to_q_expr t,Ml2C.n n)
+ | Sub(t1,t2) ->  PEsub (term_to_q_expr t1,  term_to_q_expr t2)
+ | _ -> failwith "term_to_q_expr: not implemented"
+
+let term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus  Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e)
+
+
+let rec product l = 
+ match l with
+ | [] -> Mc.PsatzZ
+ | [i] -> Mc.PsatzIn (Ml2C.nat i)
+ | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l)
 
 
 let  q_cert_of_pos  pos = 
  let rec _cert_of_pos = function
-   Axiom_eq i ->  Mc.PsatzIn (Ml2C.nat i)
+ Axiom_eq i ->  Mc.PsatzIn (Ml2C.nat i)
   | Axiom_le i ->  Mc.PsatzIn (Ml2C.nat i)
   | Axiom_lt i ->  Mc.PsatzIn (Ml2C.nat i)
   | Monoid l  -> product l
   | Rational_eq n | Rational_le n | Rational_lt n -> 
-     if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else
-      Mc.PsatzC (Ml2C.q   n)
+   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)
   | Sum (y, z) -> Mc.PsatzAdd  (_cert_of_pos y, _cert_of_pos z)
   | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in
-  simplify_cone q_spec (_cert_of_pos pos)
+ simplify_cone q_spec (_cert_of_pos pos)
 
 
- let rec term_to_z_expr = function
-  | Const n ->  PEc (Ml2C.bigint (big_int_of_num n))
-  | Zero   ->  PEc ( Z0)
-  | Var s   ->  PEX (Ml2C.index 
-		      (int_of_string (String.sub s 1 (String.length s - 1))))
-  | Mul(p1,p2) ->  PEmul(term_to_z_expr p1, term_to_z_expr p2)
-  | Add(p1,p2) ->   PEadd(term_to_z_expr p1, term_to_z_expr p2)
-  | Opp p ->   PEopp (term_to_z_expr p)
-  | Pow(t,n) ->  PEpow (term_to_z_expr t,Ml2C.n n)
-  | Sub(t1,t2) ->  PEsub (term_to_z_expr t1,  term_to_z_expr t2)
-  | _ -> failwith "term_to_z_expr: not implemented"
+let rec term_to_z_expr = function
+ | Const n ->  PEc (Ml2C.bigint (big_int_of_num n))
+ | Zero   ->  PEc ( Z0)
+ | Var s   ->  PEX (Ml2C.index 
+		     (int_of_string (String.sub s 1 (String.length s - 1))))
+ | Mul(p1,p2) ->  PEmul(term_to_z_expr p1, term_to_z_expr p2)
+ | Add(p1,p2) ->   PEadd(term_to_z_expr p1, term_to_z_expr p2)
+ | Opp p ->   PEopp (term_to_z_expr p)
+ | Pow(t,n) ->  PEpow (term_to_z_expr t,Ml2C.n n)
+ | Sub(t1,t2) ->  PEsub (term_to_z_expr t1,  term_to_z_expr t2)
+ | _ -> failwith "term_to_z_expr: not implemented"
 
- let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.Z.add  Mc.Z.mul Mc.Z.sub Mc.Z.opp Mc.zeq_bool (term_to_z_expr e)
+let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.Z.add  Mc.Z.mul Mc.Z.sub Mc.Z.opp Mc.zeq_bool (term_to_z_expr e)
 
 let  z_cert_of_pos  pos = 
  let s,pos = (scale_certificate pos) in
  let rec _cert_of_pos = function
-   Axiom_eq i ->  Mc.PsatzIn (Ml2C.nat i)
+ Axiom_eq i ->  Mc.PsatzIn (Ml2C.nat i)
   | Axiom_le i ->  Mc.PsatzIn (Ml2C.nat i)
   | Axiom_lt i ->  Mc.PsatzIn (Ml2C.nat i)
   | Monoid l  -> product l
   | Rational_eq n | Rational_le n | Rational_lt n -> 
-     if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else
-      Mc.PsatzC (Ml2C.bigint (big_int_of_num  n))
+   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) -> 
-      let is_unit =
-	match t with
-	  | Const n -> n =/ Int 1 
-	  |   _     -> false in
-	if is_unit
-	then _cert_of_pos y
-	else Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y)
+   let is_unit =
+    match t with
+    | Const n -> n =/ Int 1 
+    |   _     -> false in
+   if is_unit
+   then _cert_of_pos y
+   else Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y)
   | Sum (y, z) -> Mc.PsatzAdd  (_cert_of_pos y, _cert_of_pos z)
   | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in
-  simplify_cone z_spec (_cert_of_pos pos)
+ simplify_cone z_spec (_cert_of_pos pos)
 
 (** All constraints (initial or derived) have an index and have a justification i.e., proof.
     Given a constraint, all the coefficients are always integers.
@@ -612,116 +675,109 @@ open Num
 open Big_int
 open Polynomial
 
-(*module Mc = Micromega*)
-(*module Ml2C = Mutils.CamlToCoq
-module C2Ml = Mutils.CoqToCaml
-*)
-let debug = false
-
-
 
 module Env = 
 struct
 
-  type t = int list
+ type t = int list
 
-  let id_of_hyp hyp l = 
-    let rec xid_of_hyp i l = 
-      match l with
-      | [] -> failwith "id_of_hyp"
-      | hyp'::l -> if Pervasives.(=) hyp hyp' then i else xid_of_hyp (i+1) l in
-      xid_of_hyp 0 l
+ let id_of_hyp hyp l = 
+  let rec xid_of_hyp i l = 
+   match l with
+   | [] -> failwith "id_of_hyp"
+   | hyp'::l -> if Pervasives.(=) hyp hyp' then i else xid_of_hyp (i+1) l in
+  xid_of_hyp 0 l
 
 end
 
 
 let  coq_poly_of_linpol (p,c) = 
 
-  let pol_of_mon m =
-    Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc (Mc.Zpos Mc.XH)) in
+ let pol_of_mon m =
+  Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc (Mc.Zpos Mc.XH)) in
 
-    List.fold_left (fun acc (x,v) -> 
-		      let mn = LinPoly.MonT.retrieve x in
-			Mc.PEadd(Mc.PEmul(Mc.PEc (Ml2C.bigint (numerator v)), pol_of_mon mn),acc)) (Mc.PEc (Ml2C.bigint (numerator c))) p
-			
+ List.fold_left (fun acc (x,v) -> 
+  let mn = LinPoly.MonT.retrieve x in
+  Mc.PEadd(Mc.PEmul(Mc.PEc (Ml2C.bigint (numerator v)), pol_of_mon mn),acc)) (Mc.PEc (Ml2C.bigint (numerator c))) p
+  
 
 
 
 let rec cmpl_prf_rule env = function
-  | Hyp i | Def i -> Mc.PsatzIn (Ml2C.nat (Env.id_of_hyp i env))
-  | Cst i         -> Mc.PsatzC (Ml2C.bigint i)
-  | Zero          -> Mc.PsatzZ
-  | MulPrf(p1,p2)      -> Mc.PsatzMulE(cmpl_prf_rule env p1, cmpl_prf_rule env p2)
-  | AddPrf(p1,p2)      -> Mc.PsatzAdd(cmpl_prf_rule env p1 , cmpl_prf_rule env p2)
-  | MulC(lp,p)  -> let lp = Mc.norm0 (coq_poly_of_linpol lp) in
-      Mc.PsatzMulC(lp,cmpl_prf_rule env p)
-  | Square lp      -> Mc.PsatzSquare (Mc.norm0 (coq_poly_of_linpol lp))
-  | _                  -> failwith "Cuts should already be compiled"
-      
+ | Hyp i | Def i -> Mc.PsatzIn (Ml2C.nat (Env.id_of_hyp i env))
+ | Cst i         -> Mc.PsatzC (Ml2C.bigint i)
+ | Zero          -> Mc.PsatzZ
+ | MulPrf(p1,p2)      -> Mc.PsatzMulE(cmpl_prf_rule env p1, cmpl_prf_rule env p2)
+ | AddPrf(p1,p2)      -> Mc.PsatzAdd(cmpl_prf_rule env p1 , cmpl_prf_rule env p2)
+ | MulC(lp,p)  -> let lp = Mc.norm0 (coq_poly_of_linpol lp) in
+                  Mc.PsatzMulC(lp,cmpl_prf_rule env p)
+ | Square lp      -> Mc.PsatzSquare (Mc.norm0 (coq_poly_of_linpol lp))
+ | _                  -> failwith "Cuts should already be compiled"
+  
 
 let rec cmpl_proof env = function
-  | Done ->  Mc.DoneProof
-  | Step(i,p,prf) -> 
-      begin
-	match p with
-	| CutPrf p' -> 
-	    Mc.CutProof(cmpl_prf_rule env p', cmpl_proof (i::env) prf)
-	|   _       -> Mc.RatProof(cmpl_prf_rule env p,cmpl_proof (i::env) prf)
-      end
-  | Enum(i,p1,_,p2,l) -> 
-      Mc.EnumProof(cmpl_prf_rule env p1,cmpl_prf_rule env p2,List.map (cmpl_proof (i::env)) l)
+ | Done ->  Mc.DoneProof
+ | Step(i,p,prf) -> 
+  begin
+   match p with
+   | CutPrf p' -> 
+    Mc.CutProof(cmpl_prf_rule env p', cmpl_proof (i::env) prf)
+   |   _       -> Mc.RatProof(cmpl_prf_rule env p,cmpl_proof (i::env) prf)
+  end
+ | Enum(i,p1,_,p2,l) -> 
+  Mc.EnumProof(cmpl_prf_rule env p1,cmpl_prf_rule env p2,List.map (cmpl_proof (i::env)) l)
 
 
 let compile_proof env prf = 
-  let id = 1 + proof_max_id prf in
-  let _,prf = normalise_proof id prf in
-    if debug then Printf.fprintf stdout "compiled proof %a\n" output_proof prf;
-    cmpl_proof env prf
+ let id = 1 + proof_max_id prf in
+ let _,prf = normalise_proof id prf in
+ if debug then Printf.fprintf stdout "compiled proof %a\n" output_proof prf;
+ cmpl_proof env prf
 
 type prf_sys = (cstr_compat * prf_rule) list
 
 
 let xlinear_prover sys = 
-  match Fourier.find_point sys with
-  | Inr prf -> 
-      if debug then Printf.printf "AProof : %a\n" pp_proof prf ; 
-      let cert = (*List.map (fun (x,n) -> x+1,n)*) (fst (List.hd (Proof.mk_proof sys prf))) in
-	if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; 
-	Some (rats_to_ints (Vect.to_list cert))
-  | Inl _   -> None
+ match Fourier.find_point sys with
+ | Inr prf -> 
+  if debug then Printf.printf "AProof : %a\n" pp_proof prf ; 
+  let cert = (*List.map (fun (x,n) -> x+1,n)*) (fst (List.hd (Proof.mk_proof sys prf))) in
+  if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; 
+  Some (rats_to_ints (Vect.to_list cert))
+ | Inl _   -> None
 
 
 let output_num o n = output_string o (string_of_num n)
 let output_bigint o n = output_string o (string_of_big_int n)
 
 let proof_of_farkas prf cert = 
-(*  Printf.printf "\nproof_of_farkas  %a , %a \n" (pp_list output_prf_rule) prf (pp_list output_bigint) cert ;  *)
-  let rec mk_farkas acc prf cert = 
-    match prf, cert with
-    |   _  , []   -> acc
-    |  []  , _    -> failwith "proof_of_farkas : not enough hyps"
-    |  p::prf,c::cert -> 
-	   mk_farkas (add_proof (mul_proof c p) acc) prf cert in
-  let res =  mk_farkas Zero prf cert in
+  (*  Printf.printf "\nproof_of_farkas  %a , %a \n" (pp_list output_prf_rule) prf (pp_list output_bigint) cert ;  *)
+ let rec mk_farkas acc prf cert = 
+  match prf, cert with
+  |   _  , []   -> acc
+  |  []  , _    -> failwith "proof_of_farkas : not enough hyps"
+  |  p::prf,c::cert -> 
+   mk_farkas (add_proof (mul_proof c p) acc) prf cert in
+ let res =  mk_farkas Zero prf cert in
     (*Printf.printf "==> %a" output_prf_rule res ; *)
-    res
+ res
 
 
 let linear_prover sys =
-  let (sysi,prfi) = List.split sys in
-    match xlinear_prover sysi with
-    | None -> None
-    | Some cert -> Some (proof_of_farkas prfi cert)
+ let (sysi,prfi) = List.split sys in
+ match xlinear_prover sysi with
+ | None -> None
+ | Some cert -> Some (proof_of_farkas prfi cert)
 
 let linear_prover  = 
-  if debug 
-  then 
-    fun sys -> 
-      Printf.printf "<linear_prover"; flush stdout ;
-      let res = linear_prover sys in
-	Printf.printf ">"; flush stdout ;
-	res
-  else linear_prover
+ if debug 
+ then 
+  fun sys -> 
+   Printf.printf "<linear_prover"; flush stdout ;
+   let res = linear_prover sys in
+   Printf.printf ">"; flush stdout ;
+   res
+ else linear_prover
   
 
 
@@ -733,11 +789,11 @@ let linear_prover  =
 *)
 
 type checksat = 
-  | Tauto (* Tautology *)
-  | Unsat of prf_rule (* Unsatisfiable *)
-  | Cut of cstr_compat * prf_rule (* Cutting plane *)
-  | Normalise of cstr_compat * prf_rule (* coefficients are relatively prime *)
-      
+| Tauto (* Tautology *)
+| Unsat of prf_rule (* Unsatisfiable *)
+| Cut of cstr_compat * prf_rule (* Cutting plane *)
+| Normalise of cstr_compat * prf_rule (* coefficients are relatively prime *)
+  
 
 (** [check_sat] 
     - detects constraints that are not satisfiable;
@@ -745,83 +801,83 @@ type checksat =
 *)
 
 let check_sat (cstr,prf) = 
-  let {coeffs=coeffs ; op=op ; cst=cst} = cstr in
-    match coeffs with
-    | [] -> 
-	if eval_op op (Int 0) cst then Tauto else Unsat prf
-    | _  -> 
-	let gcdi =  (gcd_list (List.map snd coeffs)) in
-	let gcd = Big_int gcdi in
-	  if eq_num gcd (Int 1)
-	  then Normalise(cstr,prf) 
-	  else
-	    if Int.equal (sign_num (mod_num cst gcd)) 0
-	    then (* We can really normalise *)
-	      begin
-		assert (sign_num gcd >=1 ) ;
-		let cstr = {
-		  coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs; 
-		  op = op ; cst = cst // gcd
-		} in 
-		  Normalise(cstr,Gcd(gcdi,prf))
-		    (*		    Normalise(cstr,CutPrf prf)*)
-	      end
-	    else
-	      match op with
-	      | Eq -> Unsat (CutPrf prf)
-	      | Ge -> 
-		  let cstr = {
-		    coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs; 
-		    op = op ; cst = ceiling_num (cst // gcd)
-		  } in Cut(cstr,CutPrf prf)
+ let {coeffs=coeffs ; op=op ; cst=cst} = cstr in
+ match coeffs with
+ | [] -> 
+  if eval_op op (Int 0) cst then Tauto else Unsat prf
+ | _  -> 
+  let gcdi =  (gcd_list (List.map snd coeffs)) in
+  let gcd = Big_int gcdi in
+  if eq_num gcd (Int 1)
+  then Normalise(cstr,prf) 
+  else
+   if Int.equal (sign_num (mod_num cst gcd)) 0
+   then (* We can really normalise *)
+    begin
+     assert (sign_num gcd >=1 ) ;
+     let cstr = {
+      coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs; 
+      op = op ; cst = cst // gcd
+     } in 
+     Normalise(cstr,Gcd(gcdi,prf))
+	      (*		    Normalise(cstr,CutPrf prf)*)
+    end
+   else
+    match op with
+    | Eq -> Unsat (CutPrf prf)
+    | Ge -> 
+     let cstr = {
+      coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs; 
+      op = op ; cst = ceiling_num (cst // gcd)
+     } in Cut(cstr,CutPrf prf)
 
 
 (** Proof generating pivoting over variable v *)
 let pivot v (c1,p1) (c2,p2) = 
-  let {coeffs = v1 ; op = op1 ; cst = n1} = c1
-  and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in
+ let {coeffs = v1 ; op = op1 ; cst = n1} = c1
+ and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in
 
 
 
   (* Could factorise gcd... *)
-  let xpivot cv1 cv2 =
-    (
-      {coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ;
-       op = Proof.add_op op1 op2 ;
-       cst = n1 */ cv1 +/ n2 */ cv2 },
+ let xpivot cv1 cv2 =
+  (
+   {coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ;
+    op = Proof.add_op op1 op2 ;
+    cst = n1 */ cv1 +/ n2 */ cv2 },
 
-      AddPrf(mul_proof (numerator cv1) p1,mul_proof (numerator cv2) p2)) in
+   AddPrf(mul_proof (numerator cv1) p1,mul_proof (numerator cv2) p2)) in
+ 
+ match Vect.get v v1 , Vect.get v v2 with
+ | None , _ | _ , None -> None
+ | Some a   , Some b   ->
+  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
+   then 
+    let cv1 = minus_num (b */ (Int (sign_num a)))
+    and cv2 = abs_num a in
+    Some (xpivot cv1 cv2)
+   else if op2 == Eq
+   then
+    let cv1 = abs_num b 
+    and cv2 = minus_num (a */ (Int  (sign_num b))) in
+    Some (xpivot cv1 cv2)
+   else  None (* op2 could be Eq ... this might happen *)
     
-    match Vect.get v v1 , Vect.get v v2 with
-    | None , _ | _ , None -> None
-    | Some a   , Some b   ->
-	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
-          then 
-	    let cv1 = minus_num (b */ (Int (sign_num a)))
-	    and cv2 = abs_num a in
-	      Some (xpivot cv1 cv2)
-          else if op2 == Eq
-	  then
-	    let cv1 = abs_num b 
-	    and cv2 = minus_num (a */ (Int  (sign_num b))) in
-	      Some (xpivot cv1 cv2)
-	  else  None (* op2 could be Eq ... this might happen *)
-	    
 exception FoundProof of  prf_rule
 
 let simpl_sys sys = 
-  List.fold_left (fun acc (c,p) -> 
-		    match check_sat (c,p) with
-		    | Tauto -> acc
-		    | Unsat prf -> raise (FoundProof prf)
-		    | Cut(c,p)  -> (c,p)::acc
-		    | Normalise (c,p) -> (c,p)::acc) [] sys
+ List.fold_left (fun acc (c,p) -> 
+  match check_sat (c,p) with
+  | Tauto -> acc
+  | Unsat prf -> raise (FoundProof prf)
+  | Cut(c,p)  -> (c,p)::acc
+  | Normalise (c,p) -> (c,p)::acc) [] sys
 
 
 (** [ext_gcd a b] is the extended Euclid algorithm.
@@ -829,77 +885,77 @@ let simpl_sys sys =
     Source: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm
 *)
 let rec ext_gcd a b = 
-  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
-    let (s,t) = ext_gcd b r in
-      (t, sub_big_int s (mult_big_int q t))
+ 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
+  let (s,t) = ext_gcd b r in
+  (t, sub_big_int s (mult_big_int q t))
 
 
 let pp_ext_gcd a b = 
-  let a' = big_int_of_int a in
-  let b' = big_int_of_int b in
-    
-  let (x,y) = ext_gcd a' b' in
-    Printf.fprintf stdout "%s * %s + %s * %s = %s\n" 
-      (string_of_big_int x) (string_of_big_int a')
-      (string_of_big_int y) (string_of_big_int b')
-      (string_of_big_int (add_big_int (mult_big_int x a') (mult_big_int y b')))
+ let a' = big_int_of_int a in
+ let b' = big_int_of_int b in
+ 
+ let (x,y) = ext_gcd a' b' in
+ Printf.fprintf stdout "%s * %s + %s * %s = %s\n" 
+  (string_of_big_int x) (string_of_big_int a')
+  (string_of_big_int y) (string_of_big_int b')
+  (string_of_big_int (add_big_int (mult_big_int x a') (mult_big_int y 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) = 
-  let rec exist2 vect1 vect2 = 
-    match vect1 , vect2 with
-    | _ , [] | [], _ -> None
-    | (v1,n1)::vect1' , (v2, n2) :: vect2' -> 
-	if Pervasives.(=) v1 v2
-	then 
-	  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'
-	else
-	  if v1 < v2 
-	  then exist2 vect1' vect2
-	  else exist2 vect1 vect2' in
-    
-    if c1.op == Eq && c2.op == Eq 
-    then exist2 c1.coeffs c2.coeffs
-    else None
+ let rec exist2 vect1 vect2 = 
+  match vect1 , vect2 with
+  | _ , [] | [], _ -> None
+  | (v1,n1)::vect1' , (v2, n2) :: vect2' -> 
+   if Pervasives.(=) v1 v2
+   then 
+    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'
+   else
+    if v1 < v2 
+    then exist2 vect1' vect2
+    else exist2 vect1 vect2' in
+ 
+ if c1.op == Eq && c2.op == Eq 
+ then exist2 c1.coeffs c2.coeffs
+ else None
 
 let extract2 pred l =
-  let rec xextract2 rl l = 
-    match l with
-    | [] -> (None,rl) (* Did not find *)
-    | e::l ->
-	match extract (pred e) l with
-	| None,_ -> xextract2 (e::rl) l
-	| Some (r,e'),l' -> Some (r,e,e'), List.rev_append rl l' in
-    
-    xextract2 [] l
+ let rec xextract2 rl l = 
+  match l with
+  | [] -> (None,rl) (* Did not find *)
+  | e::l ->
+   match extract (pred e) l with
+   | None,_ -> xextract2 (e::rl) l
+   | Some (r,e'),l' -> Some (r,e,e'), List.rev_append rl l' in
+ 
+ xextract2 [] l
 
 
 let extract_coprime_equation psys = 
-  extract2 extract_coprime psys
+ extract2 extract_coprime psys
 
 
 let apply_and_normalise f psys =
-  List.fold_left (fun acc pc' -> 
-		    match f pc' with
-		     | None -> pc'::acc
-		     | Some pc' -> 
-			 match check_sat pc' with
-			  | Tauto -> acc
-			  | Unsat prf -> raise (FoundProof prf)
-			  | Cut(c,p)  -> (c,p)::acc
-			  | Normalise (c,p) -> (c,p)::acc
-		 ) [] psys
+ List.fold_left (fun acc pc' -> 
+  match f pc' with
+  | None -> pc'::acc
+  | Some pc' -> 
+   match check_sat pc' with
+   | Tauto -> acc
+   | Unsat prf -> raise (FoundProof prf)
+   | Cut(c,p)  -> (c,p)::acc
+   | Normalise (c,p) -> (c,p)::acc
+ ) [] psys
 
 
 
@@ -908,314 +964,317 @@ let pivot_sys v pc psys = apply_and_normalise (pivot v pc) psys
 
 
 let reduce_coprime psys = 
-  let oeq,sys = extract_coprime_equation psys in
-    match oeq with
-    | None -> None (* Nothing to do *)
-    | Some((v,n1,n2),(c1,p1),(c2,p2) ) -> 
-	let (l1,l2) = ext_gcd (numerator n1) (numerator n2) in
-	let l1' = Big_int l1 and l2' = Big_int l2 in
-	let cstr = 
-	  {coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs);
-	   op = Eq ; 
-	   cst = (l1' */ c1.cst) +/ (l2' */ c2.cst) 
-	  } in
-	let prf = add_proof (mul_proof (numerator l1') p1) (mul_proof (numerator l2') p2) in
-
-	  Some (pivot_sys v (cstr,prf) ((c1,p1)::sys))
+ let oeq,sys = extract_coprime_equation psys in
+ match oeq with
+ | None -> None (* Nothing to do *)
+ | Some((v,n1,n2),(c1,p1),(c2,p2) ) -> 
+  let (l1,l2) = ext_gcd (numerator n1) (numerator n2) in
+  let l1' = Big_int l1 and l2' = Big_int l2 in
+  let cstr = 
+   {coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs);
+    op = Eq ; 
+    cst = (l1' */ c1.cst) +/ (l2' */ c2.cst) 
+   } in
+  let prf = add_proof (mul_proof (numerator l1') p1) (mul_proof (numerator l2') p2) in
+
+  Some (pivot_sys v (cstr,prf) ((c1,p1)::sys))
 
 (** 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 
-    then 
-      try 
-	Some (fst (List.find (fun (_,n) -> n =/ (Int 1) || n=/ (Int (-1))) cstr.coeffs))
-      with Not_found -> None
-    else None in
-
-  let (oeq,sys) =  extract is_unary_equation psys in
-    match oeq with
-    | None -> None (* Nothing to do *)
-    | Some(v,pc) -> 
-	Some(pivot_sys v pc sys)
+ let is_unary_equation (cstr,prf) = 
+  if cstr.op == Eq 
+  then 
+   try 
+    Some (fst (List.find (fun (_,n) -> n =/ (Int 1) || n=/ (Int (-1))) cstr.coeffs))
+   with Not_found -> None
+  else None in
+
+ let (oeq,sys) =  extract is_unary_equation psys in
+ match oeq with
+ | None -> None (* Nothing to do *)
+ | Some(v,pc) -> 
+  Some(pivot_sys v pc sys)
 
 let reduce_non_lin_unary psys = 
 
-  let is_unary_equation (cstr,prf) = 
-    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,_) -> 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
-    else None in
-
-
-  let (oeq,sys) =   extract is_unary_equation psys in
-    match oeq with
-     | None -> None (* Nothing to do *)
-     | Some(v,pc) -> 
-	 Some(apply_and_normalise (LinPoly.pivot_eq v pc) sys)
+ let is_unary_equation (cstr,prf) = 
+  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,_) -> 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
+  else None in
+
+
+ let (oeq,sys) =   extract is_unary_equation psys in
+ match oeq with
+ | None -> None (* Nothing to do *)
+ | Some(v,pc) -> 
+  Some(apply_and_normalise (LinPoly.pivot_eq v pc) sys)
 
 let reduce_var_change psys = 
 
-  let rec rel_prime vect = 
-    match vect with
-     | [] -> None
-     | (x,v)::vect -> 
-	 let v = numerator v in
-	   try 
-	     let (x',v') = List.find (fun (_,v') -> 
-					let v' = numerator v' in 
-					  eq_big_int (gcd_big_int  v v') unit_big_int) vect in
-	       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 (oeq,sys) = extract rel_prime psys in
-    
-    match oeq with
-     | None -> None
-     | Some(((x,v),(x',v')),(c,p)) -> 
-	 let (l1,l2) = ext_gcd  v  v' in
-	 let l1,l2 = Big_int l1 , Big_int l2 in
+ let rec rel_prime vect = 
+  match vect with
+  | [] -> None
+  | (x,v)::vect -> 
+   let v = numerator v in
+   try 
+    let (x',v') = List.find (fun (_,v') -> 
+     let v' = numerator v' in 
+     eq_big_int (gcd_big_int  v v') unit_big_int) vect in
+    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 get v vect = 
-	   match Vect.get v vect with
-	    | None -> Int 0
-	    | Some n -> n in
+ let (oeq,sys) = extract rel_prime psys in
+ 
+ match oeq with
+ | None -> None
+ | Some(((x,v),(x',v')),(c,p)) -> 
+  let (l1,l2) = ext_gcd  v  v' in
+  let l1,l2 = Big_int l1 , Big_int l2 in
 
-	 let pivot_eq (c',p') = 
-	   let {coeffs = coeffs ; op = op ; cst = cst} = c' in
-	   let vx = get x coeffs in
-	   let vx' = get x' coeffs in
-	   let m = minus_num (vx */ l1 +/ vx' */ l2) in
-	     Some ({coeffs = 
-		       Vect.add (Vect.mul m c.coeffs) coeffs ; op = op ; cst = m */ c.cst +/ cst} , 
-	   AddPrf(MulC(([], m),p),p')) in
+  let get v vect = 
+   match Vect.get v vect with
+   | None -> Int 0
+   | Some n -> n in
 
-	   Some (apply_and_normalise pivot_eq sys)
+  let pivot_eq (c',p') = 
+   let {coeffs = coeffs ; op = op ; cst = cst} = c' in
+   let vx = get x coeffs in
+   let vx' = get x' coeffs in
+   let m = minus_num (vx */ l1 +/ vx' */ l2) in
+   Some ({coeffs = 
+     Vect.add (Vect.mul m c.coeffs) coeffs ; op = op ; cst = m */ c.cst +/ cst} , 
+	 AddPrf(MulC(([], m),p),p')) in
 
+  Some (apply_and_normalise pivot_eq sys)
 
 
 
-  let reduce_pivot psys = 
-    let is_equation (cstr,prf) = 
-      if cstr.op == Eq
-      then
-	try 
-	  Some (fst (List.hd cstr.coeffs))
-	with Not_found -> None
-      else None in
-    let (oeq,sys) = extract is_equation psys in
-      match oeq with
-      | None -> None (* Nothing to do *)
-      | Some(v,pc) -> 
-	  if debug then 
-	    Printf.printf "Bad news : loss of completeness %a=%s" Vect.pp_vect (fst pc).coeffs (string_of_num (fst pc).cst); 
-	  Some(pivot_sys v pc sys)
 
+let reduce_pivot psys = 
+ let is_equation (cstr,prf) = 
+  if cstr.op == Eq
+  then
+   try 
+    Some (fst (List.hd cstr.coeffs))
+   with Not_found -> None
+  else None in
+ let (oeq,sys) = extract is_equation psys in
+ match oeq with
+ | None -> None (* Nothing to do *)
+ | Some(v,pc) -> 
+  if debug then 
+   Printf.printf "Bad news : loss of completeness %a=%s" Vect.pp_vect (fst pc).coeffs (string_of_num (fst pc).cst); 
+  Some(pivot_sys v pc sys)
 
 
 
 
-  let iterate_until_stable f x = 
-    let rec iter x = 
-      match f x with
-      | None -> x
-      | Some x' -> iter x' in
-      iter x
 
-  let rec app_funs l x = 
-    match l with
-    | [] -> None
-    | f::fl -> 
-	match f x with
-	| None    -> app_funs fl x
-	| Some x' -> Some x'
+let iterate_until_stable f x = 
+ let rec iter x = 
+  match f x with
+  | None -> x
+  | Some x' -> iter x' in
+ iter x
 
-  let reduction_equations psys =
-    iterate_until_stable (app_funs 
-			    [reduce_unary ; reduce_coprime ; 
-			     reduce_var_change (*; reduce_pivot*)]) psys 
+let rec app_funs l x = 
+ match l with
+ | [] -> None
+ | f::fl -> 
+  match f x with
+  | None    -> app_funs fl x
+  | Some x' -> Some x'
 
-  let reduction_non_lin_equations psys =
-    iterate_until_stable (app_funs 
-			    [reduce_non_lin_unary (*; reduce_coprime ; 
-			     reduce_var_change ; reduce_pivot *)]) psys 
+let reduction_equations psys =
+ iterate_until_stable (app_funs 
+			[reduce_unary ; reduce_coprime ; 
+			 reduce_var_change (*; reduce_pivot*)]) psys 
+
+let reduction_non_lin_equations psys =
+ iterate_until_stable (app_funs 
+			[reduce_non_lin_unary (*; reduce_coprime ; 
+			                        reduce_var_change ; reduce_pivot *)]) psys 
 
 
 
 
   (** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *)
-  let get_bound sys = 
-    let is_small (v,i) = 
-      match Itv.range i with
-      | None -> false
-      | Some i -> i <=/ (Int 1) in
-      
-    let select_best (x1,i1) (x2,i2) = 
-      if Itv.smaller_itv i1 i2
-      then (x1,i1) else (x2,i2) in
+let get_bound sys = 
+ let is_small (v,i) = 
+  match Itv.range i with
+  | None -> false
+  | Some i -> i <=/ (Int 1) in
+ 
+ let select_best (x1,i1) (x2,i2) = 
+  if Itv.smaller_itv i1 i2
+  then (x1,i1) else (x2,i2) in
 
     (* 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
-	match eq with
-	  | [] -> List.rev_map (fun c -> c.coeffs) ineq
-	  | _  -> 
-	      List.fold_left (fun acc c -> 
-				if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq
-				then acc else c.coeffs ::acc) [] ineq in
-
-    let smallest_interval = 
-      List.fold_left 
-	(fun acc vect ->
-	   if is_small acc
-	   then acc
-	   else 
-	     match Fourier.optimise vect sys with
-	     | None -> acc
-	     | Some i -> 
-		 if debug then Printf.printf "Found a new bound %a" Vect.pp_vect vect ;
-		 select_best (vect,i) acc)  (Vect.null, (None,None)) (all_planes sys) in
-    let smallest_interval =
-      match smallest_interval
-      with
-      | (x,(Some i, Some j))  -> Some(i,x,j)
-      |   x        ->   None (* This should not be possible *)
-    in
-      match smallest_interval with
-      | Some (lb,e,ub) -> 
-	  let (lbn,lbd) = (sub_big_int (numerator lb)  unit_big_int, denominator lb) in
-	  let (ubn,ubd) = (add_big_int unit_big_int (numerator ub) , denominator ub) in
-	    (match
+ let all_planes sys = 
+  let (eq,ineq) = List.partition (fun c -> c.op == Eq) sys in
+  match eq with
+  | [] -> List.rev_map (fun c -> c.coeffs) ineq
+  | _  -> 
+   List.fold_left (fun acc c -> 
+    if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq
+    then acc else c.coeffs ::acc) [] ineq in
+
+ let smallest_interval = 
+  List.fold_left 
+   (fun acc vect ->
+    if is_small acc
+    then acc
+    else 
+     match Fourier.optimise vect sys with
+     | None -> acc
+     | Some i -> 
+      if debug then Printf.printf "Found a new bound %a" Vect.pp_vect vect ;
+      select_best (vect,i) acc)  (Vect.null, (None,None)) (all_planes sys) in
+ let smallest_interval =
+  match smallest_interval
+  with
+  | (x,(Some i, Some j))  -> Some(i,x,j)
+  |   x        ->   None (* This should not be possible *)
+ in
+ match smallest_interval with
+ | Some (lb,e,ub) -> 
+  let (lbn,lbd) = (sub_big_int (numerator lb)  unit_big_int, denominator lb) in
+  let (ubn,ubd) = (add_big_int unit_big_int (numerator ub) , denominator ub) in
+  (match
                (* x <= ub ->  x  > ub *)
-               xlinear_prover   ({coeffs = Vect.mul (Big_int ubd)  e ; op = Ge ; cst = Big_int ubn} :: sys),
+    xlinear_prover   ({coeffs = Vect.mul (Big_int ubd)  e ; op = Ge ; cst = Big_int ubn} :: sys),
                (* lb <= x  -> lb > x *)
-               xlinear_prover
-		 ({coeffs = Vect.mul (minus_num (Big_int lbd)) e ; op = Ge ; cst = minus_num (Big_int lbn)} :: sys)
-	     with
-	     | Some cub , Some clb  -> Some(List.tl clb,(lb,e,ub), List.tl cub)
-	     |         _            -> failwith "Interval without proof"
-	    )
-      | None -> None
-
-
-  let check_sys sys = 
-    List.for_all (fun (c,p) -> List.for_all (fun (_,n) -> sign_num n <> 0) c.coeffs) sys
-
-
-  let xlia reduction_equations  sys = 
-
-  let rec enum_proof (id:int) (sys:prf_sys) : proof option = 
-    if debug then (Printf.printf "enum_proof\n" ; flush stdout) ;
-    assert (check_sys sys) ; 
-
-    let nsys,prf = List.split sys in
-      match get_bound nsys with
-      | None -> None (* Is the systeme really unbounded ? *)
-      | Some(prf1,(lb,e,ub),prf2) -> 
-	  if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp_vect e (string_of_num lb) (string_of_num ub) ; 
-	  (match start_enum  id  e  (ceiling_num lb)  (floor_num ub) sys
-	   with
-	   | Some prfl -> 
-	       Some(Enum(id,proof_of_farkas prf prf1,e, proof_of_farkas prf prf2,prfl))
-	   | None -> None
-	  )
-
-  and start_enum id e clb cub sys = 
-    if clb >/ cub
-    then Some []
-    else
-      let eq = {coeffs = e ; op = Eq ; cst = clb} in
-	match aux_lia (id+1) ((eq, Def id) :: sys) with
-	| None -> None 
-	| Some prf  -> 
-	    match start_enum id e (clb +/ (Int 1)) cub sys with
-	    | None -> None
-	    | Some l -> Some (prf::l)
-
-  and aux_lia (id:int)  (sys:prf_sys) : proof option  = 
-    assert (check_sys sys) ; 
-    if debug then Printf.printf "xlia:  %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ; 
-    try 
-      let sys = reduction_equations sys in
-    if debug then 
+   xlinear_prover
+    ({coeffs = Vect.mul (minus_num (Big_int lbd)) e ; op = Ge ; cst = minus_num (Big_int lbn)} :: sys)
+   with
+   | Some cub , Some clb  -> Some(List.tl clb,(lb,e,ub), List.tl cub)
+   |         _            -> failwith "Interval without proof"
+  )
+ | None -> None
+
+
+let check_sys sys = 
+ List.for_all (fun (c,p) -> List.for_all (fun (_,n) -> sign_num n <> 0) c.coeffs) sys
+
+
+let xlia (can_enum:bool)  reduction_equations  sys = 
+
+ 
+ let rec enum_proof (id:int) (sys:prf_sys) : proof option = 
+  if debug then (Printf.printf "enum_proof\n" ; flush stdout) ;
+  assert (check_sys sys) ; 
+
+  let nsys,prf = List.split sys in
+  match get_bound nsys with
+  | None -> None (* Is the systeme really unbounded ? *)
+  | Some(prf1,(lb,e,ub),prf2) -> 
+   if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp_vect e (string_of_num lb) (string_of_num ub) ; 
+   (match start_enum  id  e  (ceiling_num lb)  (floor_num ub) sys
+    with
+    | Some prfl -> 
+     Some(Enum(id,proof_of_farkas prf prf1,e, proof_of_farkas prf prf2,prfl))
+    | None -> None
+   )
+
+ and start_enum id e clb cub sys = 
+  if clb >/ cub
+  then Some []
+  else
+   let eq = {coeffs = e ; op = Eq ; cst = clb} in
+   match aux_lia (id+1) ((eq, Def id) :: sys) with
+   | None -> None 
+   | Some prf  -> 
+    match start_enum id e (clb +/ (Int 1)) cub sys with
+    | None -> None
+    | Some l -> Some (prf::l)
+
+ and aux_lia (id:int)  (sys:prf_sys) : proof option  = 
+  assert (check_sys sys) ; 
+  if debug then Printf.printf "xlia:  %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ; 
+  try 
+   let sys = reduction_equations sys in
+   if debug then 
     Printf.printf "after reduction:  %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ; 	    	    
-	match linear_prover sys with
-	 | Some prf -> Some (Step(id,prf,Done))
-	 | None ->  enum_proof id sys
-    with FoundProof prf -> 
+   match linear_prover sys with
+   | Some prf -> Some (Step(id,prf,Done))
+   | None ->  if can_enum then enum_proof id sys else None
+  with FoundProof prf -> 
       (* [reduction_equations] can find a proof *)
-      Some(Step(id,prf,Done)) in
+   Some(Step(id,prf,Done)) in
 
   (*  let sys' = List.map (fun (p,o) -> Mc.norm0 p , o) sys in*)
-  let id  = List.length sys in
-  let orpf = 
-    try 
-      let sys = simpl_sys sys in
-	  aux_lia id sys
-    with FoundProof pr -> Some(Step(id,pr,Done)) in
-    match orpf with
-     | None -> None
-     | Some prf -> 
+ let id  = List.length sys in
+ let orpf = 
+  try 
+   let sys = simpl_sys sys in
+   aux_lia id sys
+  with FoundProof pr -> Some(Step(id,pr,Done)) in
+ match orpf with
+ | None -> None
+ | Some prf -> 
 	 (*Printf.printf "direct proof %a\n" output_proof prf ; *)
-	 let env = mapi (fun _ i -> i) sys in
-	 let prf = compile_proof env prf in
+  let env = mapi (fun _ i -> i) sys in
+  let prf = compile_proof env prf in
 	   (*try 
 	     if Mc.zChecker sys' prf then Some prf else 
 	     raise Certificate.BadCertificate
 	     with Failure s -> (Printf.printf "%s" s ; Some prf)
 	   *) Some prf
-	   
-
-  let cstr_compat_of_poly (p,o) = 
-    let (v,c) = LinPoly.linpol_of_pol p in
-      {coeffs = v ; op = o ; cst = minus_num c }
-
-
-  let lia sys = 
-    LinPoly.MonT.clear ();
-    let sys = List.map (develop_constraint z_spec) sys in
-    let (sys:cstr_compat list) = List.map cstr_compat_of_poly sys in
-    let sys = mapi (fun c i -> (c,Hyp i)) sys in
-      xlia reduction_equations sys
-
-
-  let nlia sys = 
-    LinPoly.MonT.clear ();
-    let sys = List.map (develop_constraint z_spec) sys in
-    let sys = mapi (fun c i -> (c,Hyp i)) sys in
-
-    let is_linear =  List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in
-
-    let collect_square = 
-      List.fold_left (fun acc ((p,_),_) -> Poly.fold 
-			(fun m _ acc -> 
-			   match Monomial.sqrt m with
-			     | None -> acc
-			     | Some s -> MonMap.add  s m acc)  p acc) MonMap.empty sys in
-    let sys = MonMap.fold (fun s m acc -> 
-				    let s = LinPoly.linpol_of_pol (Poly.add s (Int 1) (Poly.constant (Int 0))) in
-				    let m = Poly.add m (Int 1) (Poly.constant (Int 0)) in
-				    ((m, Ge), (Square s))::acc) collect_square  sys in
-
-(*      List.iter (fun ((p,_),_) -> Printf.printf "square %a\n" Poly.pp p) gen_square*)
-
-    let sys = 
-      if is_linear then sys
-      else sys @ (all_sym_pairs (fun ((c,o),p) ((c',o'),p') -> 
-			    ((Poly.product c c',opMult o o'), MulPrf(p,p'))) sys) in
+  
 
-    let sys = List.map (fun (c,p) -> cstr_compat_of_poly c,p) sys in
-    assert (check_sys sys) ; 
-    xlia (if is_linear then reduction_equations else reduction_non_lin_equations) sys
+let cstr_compat_of_poly (p,o) = 
+ let (v,c) = LinPoly.linpol_of_pol p in
+ {coeffs = v ; op = o ; cst = minus_num c }
+
+
+let lia (can_enum:bool) (prfdepth:int) sys = 
+ LinPoly.MonT.clear ();
+ max_nb_cstr := compute_max_nb_cstr sys prfdepth ;
+ let sys = List.map (develop_constraint z_spec) sys in
+ let (sys:cstr_compat list) = List.map cstr_compat_of_poly sys in
+ let sys = mapi (fun c i -> (c,Hyp i)) sys in
+ xlia can_enum reduction_equations sys
+
+
+let nlia enum prfdepth sys = 
+ LinPoly.MonT.clear ();
+ max_nb_cstr := compute_max_nb_cstr sys prfdepth;
+ let sys = List.map (develop_constraint z_spec) sys in
+ let sys = mapi (fun c i -> (c,Hyp i)) sys in
+
+ let is_linear =  List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in
+
+ let collect_square = 
+  List.fold_left (fun acc ((p,_),_) -> Poly.fold 
+   (fun m _ acc -> 
+    match Monomial.sqrt m with
+    | None -> acc
+    | Some s -> MonMap.add  s m acc)  p acc) MonMap.empty sys in
+ let sys = MonMap.fold (fun s m acc -> 
+  let s = LinPoly.linpol_of_pol (Poly.add s (Int 1) (Poly.constant (Int 0))) in
+  let m = Poly.add m (Int 1) (Poly.constant (Int 0)) in
+  ((m, Ge), (Square s))::acc) collect_square  sys in
+
+    (*      List.iter (fun ((p,_),_) -> Printf.printf "square %a\n" Poly.pp p) gen_square*)
+
+ let sys = 
+  if is_linear then sys
+  else sys @ (all_sym_pairs (fun ((c,o),p) ((c',o'),p') -> 
+   ((Poly.product c c',opMult o o'), MulPrf(p,p'))) sys) in
+
+ let sys = List.map (fun (c,p) -> cstr_compat_of_poly c,p) sys in
+ assert (check_sys sys) ; 
+ xlia enum (if is_linear then reduction_equations else reduction_non_lin_equations) sys
 
 
 
diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml
index cce0a728..e4b58a56 100644
--- a/plugins/micromega/coq_micromega.ml
+++ b/plugins/micromega/coq_micromega.ml
@@ -18,6 +18,7 @@
 
 open Pp
 open Mutils
+open Goptions
 
 (**
   * Debug flag 
@@ -37,6 +38,53 @@ let time str f x =
 		     flush stdout);
   res
 
+
+(* Limit the proof search *)
+
+let max_depth = max_int
+
+(* Search limit for provers over Q R *)
+let lra_proof_depth = ref max_depth
+
+ 
+(* Search limit for provers over Z *)
+let lia_enum  = ref true
+let lia_proof_depth = ref max_depth
+
+let get_lia_option () =
+ (!lia_enum,!lia_proof_depth)
+
+let get_lra_option () =
+ !lra_proof_depth
+
+
+ 
+let _ =
+ 
+ let int_opt l vref =
+  {
+   optsync = true;
+   optdepr = false;
+   optname = List.fold_right (^) l "";
+   optkey  = l ;
+   optread = (fun () -> Some !vref);
+   optwrite = (fun x -> vref := (match x with None -> max_depth | Some v -> v))
+  } in
+
+ let lia_enum_opt = 
+  {
+   optsync = true;
+   optdepr = false;
+   optname = "Lia Enum";
+   optkey  = ["Lia";"Enum"];
+   optread = (fun () -> !lia_enum);
+   optwrite = (fun x -> lia_enum := x)
+  } in
+ let _ = declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth) in
+ let _ = declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth) in 
+ let _ = declare_bool_option lia_enum_opt in
+ ()
+ 
 (**
   * Initialize a tag type to the Tag module declaration (see Mutils).
   *)
@@ -99,6 +147,17 @@ let rec map_atoms fct f =
     | N f -> N(map_atoms fct f)
     | I(f1,o,f2) -> I(map_atoms fct f1, o , map_atoms fct f2)
 
+let rec map_prop fct f =
+  match f with
+    | TT -> TT
+    | FF -> FF
+    | X x -> X (fct x)
+    | A (at,tg,cstr) -> A(at,tg,cstr)
+    | C (f1,f2) -> C(map_prop fct f1, map_prop fct f2)
+    | D (f1,f2) -> D(map_prop fct f1, map_prop fct f2)
+    | N f -> N(map_prop fct f)
+    | I(f1,o,f2) -> I(map_prop fct f1, o , map_prop fct f2)
+
 (**
   * Collect the identifiers of a (string of) implications. Implication labels
   * are inherited from Coq/CoC's higher order dependent type constructor (Pi).
@@ -244,7 +303,8 @@ let rec add_term  t0 = function
   *)
 
 module ISet = Set.Make(Int)
-
+module IMap = Map.Make(Int)
+  
 (**
   * 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.
@@ -303,7 +363,8 @@ struct
   let r_modules =
     [["Coq";"Reals" ; "Rdefinitions"];
      ["Coq";"Reals" ; "Rpow_def"] ;
-]
+     ["Coq";"Reals" ; "Raxioms"] ;
+    ]
 
   let z_modules = [["Coq";"ZArith";"BinInt"]]
 
@@ -322,6 +383,8 @@ struct
   let coq_and = lazy (init_constant "and")
   let coq_or = lazy (init_constant "or")
   let coq_not = lazy (init_constant "not")
+  let coq_not_gl_ref = (Nametab.locate (  Libnames.qualid_of_string "Coq.Init.Logic.not"))
+
   let coq_iff = lazy (init_constant "iff")
   let coq_True = lazy (init_constant "True")
   let coq_False = lazy (init_constant "False")
@@ -359,6 +422,7 @@ struct
   let coq_Qmake = lazy (constant "Qmake")
 
   let coq_Rcst = lazy (constant "Rcst")
+
   let coq_C0   = lazy (m_constant "C0")
   let coq_C1   = lazy (m_constant "C1")
   let coq_CQ   = lazy (m_constant "CQ")
@@ -415,8 +479,9 @@ struct
   let coq_Rdiv = lazy (r_constant "Rdiv")
   let coq_Rinv = lazy (r_constant "Rinv")
   let coq_Rpower = lazy (r_constant "pow")
+  let coq_IZR    = lazy (r_constant "IZR")
   let coq_IQR    = lazy (constant "IQR")
-  let coq_IZR    = lazy (constant "IZR")
+
 
   let coq_PEX = lazy (constant "PEX" )
   let coq_PEc = lazy (constant"PEc")
@@ -896,8 +961,20 @@ struct
           let (env,n) = _add l ( n+1) v in
            (e::env,n) in
     let (env, n) =  _add env 1 v in
-     (env, CamlToCoq.idx n)
+     (env, CamlToCoq.positive n)
+
+   let get_rank env v = 
 
+     let rec _get_rank env n =
+       match env with
+       | [] -> raise (Invalid_argument "get_rank")
+      | e::l ->
+         if eq_constr e v
+         then n
+         else  _get_rank l (n+1)  in 
+     _get_rank env 1
+
+       
    let empty = []
 
    let elements env = env
@@ -910,7 +987,7 @@ struct
 
   let parse_expr parse_constant parse_exp ops_spec env term =
     if debug
-    then Pp.msg_debug (Pp.str "parse_expr: " ++ Printer.prterm term);
+    then Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.prterm term);
 
 (*
     let constant_or_variable env term =
@@ -947,7 +1024,7 @@ struct
                            let (expr,env) = parse_expr env args.(0) in
                            let power = (parse_exp expr args.(1)) in
                              (power  , env)
-			 with e when Errors.noncritical e ->
+			 with e when CErrors.noncritical e ->
                            (* if the exponent is a variable *)
                            let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env)
                        end
@@ -994,7 +1071,7 @@ struct
       coq_Rplus , (fun x y -> Mc.CPlus(x,y)) ;
       coq_Rminus , (fun x y -> Mc.CMinus(x,y)) ; 
       coq_Rmult  , (fun x y -> Mc.CMult(x,y)) ; 
-      coq_Rdiv   , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;
+    (*      coq_Rdiv   , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;*)
     ]
 
   let rec rconstant term =
@@ -1016,10 +1093,14 @@ struct
 	  with
 	      ParseError -> 
 		match op with
-		  | 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
+		| op when Constr.equal op (Lazy.force coq_Rinv) ->
+                  let arg = rconstant args.(0) in 
+                  if Mc.qeq_bool (Mc.q_of_Rcst arg) {Mc.qnum = Mc.Z0 ; Mc.qden = Mc.XH}
+                  then raise ParseError (* This is a division by zero -- no semantics *)
+                  else Mc.CInv(arg) 
+		| op when Constr.equal op (Lazy.force coq_IQR)  -> Mc.CQ (parse_q args.(0))
+		| op when Constr.equal op   (Lazy.force coq_IZR)  -> Mc.CZ (parse_z args.(0))
+		| _ ->  raise ParseError
 	end
 
     |  _ -> raise ParseError
@@ -1027,7 +1108,7 @@ struct
 
   let rconstant term = 
     if debug
-    then Pp.msg_debug (Pp.str "rconstant: " ++ Printer.prterm term ++ fnl ());
+    then Feedback.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) ;
@@ -1067,7 +1148,7 @@ struct
 
   let  parse_arith parse_op parse_expr env cstr gl =
    if debug
-   then Pp.msg_debug (Pp.str "parse_arith: " ++ Printer.prterm  cstr ++ fnl ());
+   then Feedback.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 gl (op,args) in
@@ -1094,10 +1175,6 @@ struct
    | N (a) -> Mc.N(f2f a)
    | I(a,_,b)  -> Mc.I(f2f a,f2f b)
 
-  let is_prop t =
-   match t with
-    | Names.Anonymous -> true (* Not quite right *)
-    | Names.Name x    -> false
 
   let mkC f1 f2 = C(f1,f2)
   let mkD f1 f2 = D(f1,f2)
@@ -1119,34 +1196,40 @@ struct
       try
         let (at,env) = parse_atom env t gl in
         (A(at,tg,t), env,Tag.next tg)
-      with e when Errors.noncritical e -> (X(t),env,tg) in
+      with e when CErrors.noncritical e -> (X(t),env,tg) in
 
+    let is_prop term =
+      let sort  = Retyping.get_sort_of (Tacmach.pf_env gl)  (Tacmach.project gl) term in 
+     Term.is_prop_sort sort in
+     
     let rec xparse_formula env tg term =
-     match kind_of_term term with
+      match kind_of_term term with
       | App(l,rst) ->
-          (match rst with
-           | [|a;b|] when eq_constr l (Lazy.force coq_and) ->
-               let f,env,tg = xparse_formula env tg a in
-               let g,env, tg = xparse_formula env tg b  in
-               mkformula_binary mkC term f g,env,tg
-           | [|a;b|] when eq_constr l (Lazy.force coq_or) ->
-               let f,env,tg = xparse_formula env tg a in
-               let g,env,tg  = xparse_formula env tg b in
-               mkformula_binary mkD term f g,env,tg
-           | [|a|] when eq_constr l (Lazy.force coq_not) ->
-               let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg)
-           | [|a;b|] when eq_constr l (Lazy.force coq_iff) ->
-               let f,env,tg = xparse_formula env tg a in
-               let g,env,tg = xparse_formula env tg b in
-               mkformula_binary mkIff term f g,env,tg
-           | _ -> parse_atom env tg term)
-      | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b) ->
+        (match rst with
+        | [|a;b|] when eq_constr l (Lazy.force coq_and) ->
+          let f,env,tg = xparse_formula env tg a in
+          let g,env, tg = xparse_formula env tg b  in
+          mkformula_binary mkC term f g,env,tg
+        | [|a;b|] when eq_constr l (Lazy.force coq_or) ->
+          let f,env,tg = xparse_formula env tg a in
+          let g,env,tg  = xparse_formula env tg b in
+          mkformula_binary mkD term f g,env,tg
+        | [|a|] when eq_constr l (Lazy.force coq_not) ->
+          let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg)
+        | [|a;b|] when eq_constr l (Lazy.force coq_iff) ->
           let f,env,tg = xparse_formula env tg a in
           let g,env,tg = xparse_formula env tg b in
-          mkformula_binary mkI term f g,env,tg
+          mkformula_binary mkIff term f g,env,tg
+        | _ -> parse_atom env tg term)
+      | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b)->
+        let f,env,tg = xparse_formula env tg a in
+        let g,env,tg = xparse_formula env tg b in
+        mkformula_binary mkI term f g,env,tg
       | _ when eq_constr term (Lazy.force coq_True) -> (TT,env,tg)
       | _ when eq_constr term (Lazy.force coq_False) -> (FF,env,tg)
-      | _  -> X(term),env,tg in
+      | _ when is_prop term -> X(term),env,tg
+      | _ -> raise ParseError
+    in
     xparse_formula env tg  ((*Reductionops.whd_zeta*) term)
 
   let dump_formula typ dump_atom f =
@@ -1162,12 +1245,214 @@ struct
      | X(t) -> mkApp(Lazy.force coq_X,[|typ ; t|])  in
    xdump f
 
-  (**
-    * Given a conclusion and a list of affectations, rebuild a term prefixed by
-    * the appropriate letins.
-    * TODO: reverse the list of bindings!
-    *)
 
+  let prop_env_of_formula form =
+    let rec doit env = function
+      | TT | FF | A(_,_,_) -> env
+      | X t -> fst (Env.compute_rank_add env t)
+      | C(f1,f2) | D(f1,f2) | I(f1,_,f2) -> 
+        doit (doit env f1) f2
+      | N f -> doit env f in
+    
+    doit [] form
+
+  let var_env_of_formula form =
+
+    let rec vars_of_expr  = function
+      | Mc.PEX n -> ISet.singleton (CoqToCaml.positive n)
+      | Mc.PEc z -> ISet.empty
+      | Mc.PEadd(e1,e2) | Mc.PEmul(e1,e2) | Mc.PEsub(e1,e2) ->
+        ISet.union (vars_of_expr e1) (vars_of_expr e2)
+      | Mc.PEopp e | Mc.PEpow(e,_)-> vars_of_expr e
+    in
+    
+    let vars_of_atom  {Mc.flhs ; Mc.fop; Mc.frhs} =
+      ISet.union (vars_of_expr flhs) (vars_of_expr frhs) in
+      
+    let rec doit = function
+      |  TT | FF | X _ -> ISet.empty
+      | A (a,t,c) -> vars_of_atom a
+      | C(f1,f2) | D(f1,f2) |I (f1,_,f2) -> ISet.union (doit f1) (doit f2)
+      | N f -> doit f in
+
+    doit  form
+    
+
+
+      
+  type 'cst dump_expr =  (* 'cst is the type of the syntactic constants *)
+    {
+      interp_typ : constr; 
+      dump_cst : 'cst -> constr; 
+      dump_add : constr; 
+      dump_sub : constr;
+      dump_opp : constr;
+      dump_mul : constr;
+      dump_pow : constr;
+      dump_pow_arg : Mc.n -> constr;
+      dump_op  : (Mc.op2 * Term.constr) list
+    }
+
+let dump_zexpr = lazy
+  {
+    interp_typ = Lazy.force coq_Z;
+    dump_cst = dump_z;
+    dump_add = Lazy.force coq_Zplus;
+    dump_sub = Lazy.force coq_Zminus;
+    dump_opp = Lazy.force coq_Zopp;
+    dump_mul = Lazy.force coq_Zmult;
+    dump_pow = Lazy.force coq_Zpower;
+    dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n)));
+    dump_op  = List.map (fun (x,y) -> (y,Lazy.force x)) zop_table
+  }
+
+let dump_qexpr = lazy
+  {
+    interp_typ = Lazy.force coq_Q;
+    dump_cst = dump_q;
+    dump_add = Lazy.force coq_Qplus;
+    dump_sub = Lazy.force coq_Qminus;
+    dump_opp = Lazy.force coq_Qopp;
+    dump_mul = Lazy.force coq_Qmult;
+    dump_pow = Lazy.force coq_Qpower;
+    dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n)));
+    dump_op  = List.map (fun (x,y) -> (y,Lazy.force x)) qop_table      
+  }
+
+  let dump_positive_as_R p =
+  let mult = Lazy.force coq_Rmult in
+  let add  = Lazy.force coq_Rplus  in
+
+  let one  = Lazy.force coq_R1    in 
+  let mk_add x y  = mkApp(add,[|x;y|]) in
+  let mk_mult x y = mkApp(mult,[|x;y|]) in
+
+  let two  = mk_add one one in 
+
+  let rec dump_positive p = 
+      match p with
+      | Mc.XH   -> one
+      | Mc.XO p -> mk_mult two (dump_positive p)
+      | Mc.XI p -> mk_add one (mk_mult two (dump_positive p)) in
+
+  dump_positive p
+
+let dump_n_as_R n =
+  let z = CoqToCaml.n n in
+  if z = 0
+  then Lazy.force coq_R0
+  else dump_positive_as_R (CamlToCoq.positive z)
+    
+
+let rec dump_Rcst_as_R cst = 
+  match cst with
+  | Mc.C0 -> Lazy.force coq_R0 
+  | Mc.C1 ->  Lazy.force coq_R1
+  | Mc.CQ q ->  Term.mkApp(Lazy.force coq_IQR, [| dump_q q |])
+  | Mc.CZ z -> Term.mkApp(Lazy.force coq_IZR, [| dump_z z |])
+  | Mc.CPlus(x,y) -> Term.mkApp(Lazy.force coq_Rplus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |])
+  | Mc.CMinus(x,y) -> Term.mkApp(Lazy.force coq_Rminus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |])
+  | Mc.CMult(x,y) -> Term.mkApp(Lazy.force coq_Rmult, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |])
+  | Mc.CInv t -> Term.mkApp(Lazy.force coq_Rinv, [| dump_Rcst_as_R t |])
+  | Mc.COpp t -> Term.mkApp(Lazy.force coq_Ropp, [| dump_Rcst_as_R t |])
+
+
+let dump_rexpr = lazy
+  {
+    interp_typ = Lazy.force coq_R;
+    dump_cst = dump_Rcst_as_R;
+    dump_add = Lazy.force coq_Rplus;
+    dump_sub = Lazy.force coq_Rminus;
+    dump_opp = Lazy.force coq_Ropp;
+    dump_mul = Lazy.force coq_Rmult;
+    dump_pow = Lazy.force coq_Rpower;
+    dump_pow_arg = (fun n -> dump_nat (CamlToCoq.nat (CoqToCaml.n n)));
+    dump_op  = List.map (fun (x,y) -> (y,Lazy.force x)) rop_table      
+  }
+
+
+    
+    
+(** [make_goal_of_formula depxr vars props form] where 
+     - vars is an environment for the arithmetic variables occuring in form
+     - props is an environment for the propositions occuring in form
+    @return a goal where all the variables and propositions of the formula are quantified
+
+*) 
+
+let rec make_goal_of_formula dexpr form =
+
+  let vars_idx =
+    List.mapi (fun i v -> (v, i+1))  (ISet.elements (var_env_of_formula form)) in
+
+  (*  List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*)
+  
+  let props     = prop_env_of_formula form in 
+
+  let vars_n  = List.map (fun (_,i) -> (Names.id_of_string (Printf.sprintf "__x%i" i)) , dexpr.interp_typ) vars_idx in 
+  let props_n = List.mapi (fun i _ -> (Names.id_of_string (Printf.sprintf "__p%i" (i+1))) , Term.mkProp) props in 
+
+  let var_name_pos = List.map2 (fun (idx,_) (id,_) -> id,idx) vars_idx vars_n in
+
+  let  dump_expr i e =
+    let rec dump_expr  = function
+    | Mc.PEX n -> mkRel (i+(List.assoc (CoqToCaml.positive n)  vars_idx))
+    | Mc.PEc z -> dexpr.dump_cst z
+    | Mc.PEadd(e1,e2) -> mkApp(dexpr.dump_add,
+                               [| dump_expr e1;dump_expr e2|])
+    | Mc.PEsub(e1,e2) -> mkApp(dexpr.dump_sub,
+                               [| dump_expr  e1;dump_expr  e2|])
+    | Mc.PEopp e -> mkApp(dexpr.dump_opp,
+                          [| dump_expr  e|])
+    | Mc.PEmul(e1,e2) ->  mkApp(dexpr.dump_mul,
+                                [| dump_expr  e1;dump_expr e2|])
+    | Mc.PEpow(e,n) ->  mkApp(dexpr.dump_pow,
+                              [| dump_expr  e; dexpr.dump_pow_arg  n|])
+    in dump_expr e in
+  
+  let mkop op e1 e2 =
+      try
+        Term.mkApp(List.assoc op dexpr.dump_op, [| e1; e2|])
+      with Not_found ->
+        Term.mkApp(Lazy.force coq_Eq,[|dexpr.interp_typ ; e1 ;e2|]) in
+    
+  let dump_cstr i { Mc.flhs ; Mc.fop ; Mc.frhs } =
+    mkop fop (dump_expr i flhs) (dump_expr i frhs) in
+  
+  let rec xdump pi xi f =
+    match f with
+    | TT  -> Lazy.force coq_True
+    | FF  -> Lazy.force coq_False
+    | C(x,y) -> mkApp(Lazy.force coq_and,[|xdump pi xi x ; xdump pi xi y|])
+    | D(x,y) -> mkApp(Lazy.force coq_or,[| xdump pi xi x ; xdump pi xi y|])
+    | I(x,_,y) -> mkArrow (xdump pi xi x) (xdump (pi+1) (xi+1) y)
+    | N(x) -> mkArrow (xdump pi xi x) (Lazy.force coq_False)
+    | A(x,_,_) -> dump_cstr xi x
+    | X(t) -> let idx = Env.get_rank props t in
+              mkRel (pi+idx) in 
+  
+  let nb_vars  = List.length vars_n  in
+  let nb_props = List.length props_n in 
+
+  (*  Printf.fprintf stdout "NBProps : %i\n" nb_props ;*)
+  
+  let subst_prop p =
+    let idx = Env.get_rank props p in
+    mkVar (Names.id_of_string (Printf.sprintf "__p%i"  idx)) in 
+
+  let form' = map_prop subst_prop   form in
+
+  (Term.prodn nb_props (List.map (fun (x,y) -> Names.Name x,y) props_n)
+     (Term.prodn nb_vars (List.map (fun (x,y) -> Names.Name x,y) vars_n)
+        (xdump (List.length vars_n) 0  form)),
+   List.rev props_n, List.rev var_name_pos,form')
+    
+  (**
+     * Given a conclusion and a list of affectations, rebuild a term prefixed by
+     * the appropriate letins.
+     * TODO: reverse the list of bindings!
+  *)
+    
   let set l concl =
    let rec xset acc = function
     | [] -> acc
@@ -1242,29 +1527,25 @@ let coq_Empty = lazy
  (Coqlib.gen_constant_in_modules "VarMap"
    [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty")
 
-let btree_of_array typ a  =
- let size_of_a = Array.length a in
- let semi_size_of_a = size_of_a lsr 1 in
- let node = Lazy.force coq_Node
- and leaf = Lazy.force coq_Leaf
- and empty = Term.mkApp (Lazy.force coq_Empty, [| typ |]) in
- let rec aux n =
-  if n > size_of_a
-  then empty
-  else if  n > semi_size_of_a
-  then Term.mkApp (leaf, [| typ; a.(n-1) |])
-  else Term.mkApp (node, [| typ; aux (2*n); a.(n-1); aux (2*n+1) |])
- in
-  aux 1
-
-let btree_of_array typ a =
- try
-  btree_of_array typ a
- with x when Errors.noncritical x ->
-  failwith (Printf.sprintf "btree of array : %s" (Printexc.to_string x))
-
-let dump_varmap typ env =
- btree_of_array typ (Array.of_list env)
+let coq_VarMap = lazy
+  (Coqlib.gen_constant_in_modules "VarMap"
+     [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t")
+ 
+
+let rec dump_varmap typ m =
+  match m with
+  | Mc.Empty -> Term.mkApp(Lazy.force coq_Empty,[| typ |])
+  | Mc.Leaf v -> Term.mkApp(Lazy.force coq_Leaf,[| typ; v|])
+  | Mc.Node(l,o,r) ->
+    Term.mkApp (Lazy.force coq_Node, [| typ; dump_varmap typ l; o ; dump_varmap typ r |])
+
+
+let vm_of_list env =
+  match env with
+  | [] -> Mc.Empty
+  | (d,_)::_ -> 
+    List.fold_left (fun vm (c,i) ->
+      Mc.vm_add d (CamlToCoq.positive i) c vm) Mc.Empty env 
 
 
 let rec pp_varmap o vm =
@@ -1329,7 +1610,7 @@ let rec parse_hyps gl parse_arith env tg hyps =
       try
        let (c,env,tg) = parse_formula gl parse_arith env  tg t in
 	((i,c)::lhyps, env,tg)
-      with e when Errors.noncritical e -> (lhyps,env,tg)
+      with e when CErrors.noncritical e -> (lhyps,env,tg)
        (*(if debug then Printf.printf "parse_arith : %s\n" x);*)
 
 
@@ -1377,50 +1658,81 @@ let rcst_domain_spec  = lazy {
  dump_proof = dump_psatz coq_Q dump_q
 }
 
+open Proofview.Notations
+
+(** Naive topological sort of constr according to the subterm-ordering *)
+
+(* An element is minimal x is minimal w.r.t y if 
+   x <= y or (x and y are incomparable) *)
+
+let is_min le x y =
+  if le x y then true
+  else    if le y x then false else true
+
+let is_minimal le l c = List.for_all (is_min le c) l
+    
+let find_rem p l =
+  let rec xfind_rem  acc l =
+    match l with
+    | [] -> (None, acc)
+    | x :: l -> if p x then (Some x, acc @ l)
+      else xfind_rem (x::acc) l in
+  xfind_rem [] l
+
+let find_minimal le l = find_rem (is_minimal le l) l
+  
+let rec mk_topo_order le l =
+  match find_minimal le l with
+  | (None , _) -> []
+  | (Some v,l') -> v ::  (mk_topo_order le l')
+
+    
+let topo_sort_constr l = mk_topo_order Termops.dependent l
+
+
 (**
   * Instanciate the current Coq goal with a Micromega formula, a varmap, and a
   * witness.
   *)
 
-
-
-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 micromega_order_change spec cert cert_typ env ff  (*: unit Proofview.tactic*) = 
+ (* let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(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 vm = dump_varmap (spec.typ) env in
- (* 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|])); 
-      ("__wit", cert, cert_typ)
-     ]
-     (Tacmach.pf_concl gl))) gl);
-  Tactics.generalize env ;
-  Tacticals.tclTHENSEQ (List.map (fun id -> Proofview.V82.of_tactic (Tactics.introduction id)) ids) ; 
- ] 
-
+ let vm = dump_varmap (spec.typ) (vm_of_list env) in
+ (* todo : directly generate the proof term - or generalize before conversion? *)
+  Proofview.Goal.nf_enter { enter = begin fun gl -> 
+   let gl = Tacmach.New.of_old (fun x -> x) gl in
+   Tacticals.New.tclTHENLIST
+    [
+     Tactics.change_concl
+    (set
+      [
+       ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |]));
+       ("__varmap", vm, Term.mkApp(Lazy.force coq_VarMap, [|spec.typ|]));
+       ("__wit", cert, cert_typ)
+      ]
+      (Tacmach.pf_concl gl))
+  ] 
+  end }
 
 
 (**
   * The datastructures that aggregate prover attributes.
   *)
 
-type ('a,'prf) prover = {
+type ('option,'a,'prf) prover = {
   name : string ; (* name of the prover *)
-  prover : 'a list -> 'prf option ; (* the prover itself *)
+ get_option : unit ->'option ; (* find the options of the prover *)              
+ prover : 'option * 'a list -> 'prf option ; (* the prover itself *)
   hyps : 'prf -> ISet.t ; (* extract the indexes of the hypotheses really used in the proof *)
   compact : 'prf -> (int -> int) -> 'prf ; (* remap the hyp indexes according to function *)
   pp_prf : out_channel -> 'prf -> unit ;(* pretting printing of proof *)
   pp_f   : out_channel -> 'a   -> unit (* pretty printing of the formulas (polynomials)*)
 }
 
+
+ 
 (**
   * Given a list of provers and a disjunction of atoms, find a proof of any of
   * the atoms.  Returns an (optional) pair of a proof and a prover
@@ -1430,7 +1742,7 @@ type ('a,'prf) prover = {
 let find_witness provers polys1 =
   let provers = List.map (fun p ->
     (fun l ->
-      match p.prover l with
+      match p.prover (p.get_option (),l) with
         | None -> None
         | Some prf -> Some(prf,p)) , p.name) provers in
   try_any provers (List.map fst polys1)
@@ -1482,10 +1794,10 @@ 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 Errors.noncritical x ->
+    let res = try prover.compact prf remap with x when CErrors.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
+      match prover.prover (prover.get_option () ,List.map fst new_cl) with
         | None -> failwith "proof compaction error"
         | Some p ->  p
     in
@@ -1562,6 +1874,7 @@ let rec abstract_wrt_formula f1 f2 =
 
 exception CsdpNotFound
 
+  
 (**
   * This is the core of Micromega: apply the prover, analyze the result and
   * prune unused fomulas, and finally modify the proof state.
@@ -1586,12 +1899,12 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2
 
  if debug then
    begin
-     Pp.pp (Pp.str "Formula....\n") ;
+     Feedback.msg_notice (Pp.str "Formula....\n") ;
      let formula_typ = (Term.mkApp(Lazy.force coq_Cstr, [|spec.coeff|])) in
      let ff = dump_formula formula_typ
        (dump_cstr spec.typ spec.dump_coeff) ff in
-       Pp.pp (Printer.prterm ff) ;  Pp.pp_flush ();
-         Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff
+       Feedback.msg_notice (Printer.prterm ff);
+       Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff
    end;
 
  match witness_list_tags prover cnf_ff with
@@ -1611,11 +1924,11 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2
 
   if debug then
     begin
-      Pp.pp (Pp.str "\nAFormula\n") ;
+      Feedback.msg_notice (Pp.str "\nAFormula\n") ;
       let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in
       let ff' = dump_formula formula_typ
         (dump_cstr spec.typ spec.dump_coeff) ff' in
-        Pp.pp (Printer.prterm  ff') ;  Pp.pp_flush ();
+        Feedback.msg_notice (Printer.prterm  ff');
         Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff'
     end;
 
@@ -1646,58 +1959,103 @@ let micromega_gen
     (negate:'cst atom -> 'cst mc_cnf)
     (normalise:'cst atom -> 'cst mc_cnf)
     unsat deduce 
-    spec prover gl =
-  let concl = Tacmach.pf_concl gl in
-  let hyps  = Tacmach.pf_hyps_types gl in
-  try
-   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
-
+    spec dumpexpr prover tac =
+ Proofview.Goal.nf_enter { enter = begin fun gl -> 
+    let gl = Tacmach.New.of_old (fun x -> x) gl in
+    let concl = Tacmach.pf_concl gl in
+    let hyps  = Tacmach.pf_hyps_types gl in
+    try
+     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
+     let dumpexpr = Lazy.force dumpexpr in
+     
      match micromega_tauto  negate normalise unsat deduce spec prover env hyps concl gl with
-       | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl
-       | Some (ids,ff',res') -> 
-	   (Tacticals.tclTHENSEQ
-	      [
-		Tactics.generalize (List.map Term.mkVar ids) ;
-		micromega_order_change  spec res' 
-		  (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env ff'
-	      ]) gl
-  with
-   | ParseError  -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl
-   | CsdpNotFound -> flush stdout ; Pp.pp_flush () ;
-      Tacticals.tclFAIL 0 (Pp.str 
-      (" Skipping what remains of this tactic: the complexity of the goal requires "
-      ^ "the use of a specialized external tool called csdp. \n\n" 
-      ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n"
-      ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) gl
-
-
-
-let micromega_order_changer cert env ff gl =
+     | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness")
+     | Some (ids,ff',res') -> 
+       let (arith_goal,props,vars,ff_arith) = make_goal_of_formula dumpexpr ff' in
+       let intro (id,_) = Tactics.introduction id  in 
+
+       let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in
+       let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in
+       let ipat_of_name id = Some (Loc.ghost, Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in
+       let goal_name = Tactics.fresh_id [] (Names.Id.of_string "__arith") gl in
+       let env' = List.map (fun (id,i) -> Term.mkVar id,i) vars in 
+
+       let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; 
+                                                    micromega_order_change spec res'
+                                                      (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env' ff_arith ] in
+
+       let goal_props = List.rev (prop_env_of_formula ff') in 
+
+       let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in 
+       
+       let arith_args = goal_props @ goal_vars in
+
+       let kill_arith = 
+           Tacticals.New.tclTHEN
+             (Tactics.keep [])
+             ((*Tactics.tclABSTRACT  None*)
+                (Tacticals.New.tclTHEN tac_arith tac)) in 
+
+       Tacticals.New.tclTHENS
+         (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal)
+         [
+           kill_arith;
+           (Tacticals.New.tclTHENLIST
+            [(Tactics.generalize (List.map Term.mkVar ids));
+             Tactics.exact_check (Term.applist (Term.mkVar goal_name, arith_args))
+            ] )
+         ]
+    with
+    | ParseError  -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment")
+    | Mfourier.TimeOut  -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout")
+    | CsdpNotFound -> flush stdout ;
+     Tacticals.New.tclFAIL 0 (Pp.str 
+                           (" Skipping what remains of this tactic: the complexity of the goal requires "
+                            ^ "the use of a specialized external tool called csdp. \n\n" 
+                            ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n"
+                            ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp"))
+  end }
+
+let micromega_gen parse_arith 
+    (negate:'cst atom -> 'cst mc_cnf)
+    (normalise:'cst atom -> 'cst mc_cnf)
+    unsat deduce 
+    spec prover  =
+ (micromega_gen parse_arith negate normalise unsat deduce spec prover)
+ 
+       
+
+let micromega_order_changer cert env ff  = 
+  (*let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *)
   let coeff = Lazy.force coq_Rcst in
   let dump_coeff = dump_Rcst in
   let typ  = Lazy.force coq_R in
   let cert_typ = (Term.mkApp(Lazy.force coq_list, [|Lazy.force coq_QWitness |])) in
-
- 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
-  Proofview.V82.of_tactic (Tactics.change_concl
-   (set
+ 
+  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) (vm_of_list env) in
+  Proofview.Goal.nf_enter { enter = begin fun gl -> 
+    let gl = Tacmach.New.of_old (fun x -> x) gl in
+    Tacticals.New.tclTHENLIST
      [
-      ("__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", [|typ|]));
-      ("__wit", cert, cert_typ)
+     (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", [|typ|]));
+         ("__wit", cert, cert_typ)
+        ]
+        (Tacmach.pf_concl gl)));
+     (*      Tacticals.New.tclTHENLIST (List.map (fun id ->  (Tactics.introduction id)) ids)*)
      ]
-     (Tacmach.pf_concl gl)
-   ))
-   gl
-
+  end }
 
-let micromega_genr prover gl =
+let micromega_genr prover tac =
   let parse_arith = parse_rarith in
   let negate = Mc.rnegate in
   let normalise = Mc.rnormalise in
@@ -1710,41 +2068,77 @@ let micromega_genr prover gl =
     proof_typ = Lazy.force coq_QWitness ;
     dump_proof = dump_psatz coq_Q dump_q
   } in
-    
-  let concl = Tacmach.pf_concl gl in
-  let hyps  = Tacmach.pf_hyps_types gl in
-  try
-   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
-
-   let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in
-   let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in
-
-     match micromega_tauto  negate normalise unsat deduce spec prover env hyps' concl' gl with
-       | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl
+  Proofview.Goal.nf_enter { enter = begin fun gl -> 
+     let gl = Tacmach.New.of_old (fun x -> x) gl in
+     let concl = Tacmach.pf_concl gl in
+     let hyps  = Tacmach.pf_hyps_types gl in
+
+     try
+      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
+       
+       let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in
+       let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in
+       
+       match micromega_tauto  negate normalise unsat deduce spec prover env hyps' concl' gl with
+       | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") 
        | Some (ids,ff',res') -> 
-           let (ff,ids') = formula_hyps_concl 
+         let (ff,ids) = formula_hyps_concl 
 	     (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in
+         let ff' = abstract_wrt_formula ff' ff  in
+
+         let (arith_goal,props,vars,ff_arith) = make_goal_of_formula (Lazy.force dump_rexpr)  ff' in
+         let intro (id,_) = Tactics.introduction id  in 
+
+       let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in
+       let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in
+       let ipat_of_name id = Some (Loc.ghost, Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in
+       let goal_name = Tactics.fresh_id [] (Names.Id.of_string "__arith") gl in
+       let env' = List.map (fun (id,i) -> Term.mkVar id,i) vars in 
+       
+       let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; 
+                                                    micromega_order_changer res' env' ff_arith ] in
+
+       let goal_props = List.rev (prop_env_of_formula ff') in 
+
+       let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in 
+       
+       let arith_args = goal_props @ goal_vars in
+
+       let kill_arith = 
+           Tacticals.New.tclTHEN
+             (Tactics.keep [])
+             ((*Tactics.tclABSTRACT  None*)
+                (Tacticals.New.tclTHEN tac_arith tac)) in 
 
-           (Tacticals.tclTHENSEQ
-              [
-                Tactics.generalize (List.map Term.mkVar ids) ;
-                micromega_order_changer res' env (abstract_wrt_formula ff' ff)
-              ]) gl
-  with
-   | ParseError  -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl
-   | CsdpNotFound -> flush stdout ; Pp.pp_flush () ;
-      Tacticals.tclFAIL 0 (Pp.str 
-      (" Skipping what remains of this tactic: the complexity of the goal requires "
-      ^ "the use of a specialized external tool called csdp. \n\n" 
-      ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n"
-      ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) gl
+       Tacticals.New.tclTHENS
+         (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal)
+         [
+           kill_arith;
+           (Tacticals.New.tclTHENLIST
+            [(Tactics.generalize (List.map Term.mkVar ids));
+             Tactics.exact_check (Term.applist (Term.mkVar goal_name, arith_args))
+            ] )
+         ]
 
+    with
+    | ParseError  -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment")
+    | Mfourier.TimeOut  -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout")
+    | CsdpNotFound -> flush stdout ;
+     Tacticals.New.tclFAIL 0 (Pp.str 
+                           (" Skipping what remains of this tactic: the complexity of the goal requires "
+                            ^ "the use of a specialized external tool called csdp. \n\n" 
+                            ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n"
+                            ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp"))
+  end }
 
 
 
 
+let micromega_genr prover  = (micromega_genr prover)
+
+
 let lift_ratproof  prover l =
  match prover l with
   | None -> None
@@ -1766,7 +2160,7 @@ module Cache = PHashtable(struct
   let hash  = Hashtbl.hash
 end)
 
-let csdp_cache = "csdp.cache"
+let csdp_cache = ".csdp.cache"
 
 (**
   * Build the command to call csdpcert, and launch it. This in turn will call
@@ -1818,7 +2212,7 @@ let call_csdpcert_q provername poly =
      let cert = Certificate.q_cert_of_pos cert in
      if Mc.qWeakChecker poly cert
      then Some cert
-     else ((print_string "buggy certificate" ; flush stdout) ;None)
+     else ((print_string "buggy certificate") ;None)
 
 let call_csdpcert_z provername poly =
  let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in
@@ -1898,38 +2292,61 @@ let compact_pt pt f =
 
 let lift_pexpr_prover p l =  p (List.map (fun (e,o) -> Mc.denorm e , o) l)
 
-let linear_prover_Z = {
-  name    = "linear prover" ;
-  prover  = lift_ratproof (lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec)) ;
-  hyps    = hyps_of_pt ;
-  compact = compact_pt ;
-  pp_prf  = pp_proof_term;
-  pp_f    = fun o x -> pp_pol pp_z o (fst x)
-}
+module CacheZ = PHashtable(struct
+ type prover_option = bool * int
+
+ type t = prover_option * ((Mc.z Mc.pol * Mc.op1) list)
+  let equal = (=)
+  let hash  = Hashtbl.hash
+end)
 
+module CacheQ = PHashtable(struct
+  type t = int * ((Mc.q Mc.pol * Mc.op1) list)
+  let equal = (=)
+  let hash  = Hashtbl.hash
+end)
+
+let memo_zlinear_prover = CacheZ.memo ".lia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.lia ce b) s)
+let memo_nlia = CacheZ.memo ".nia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.nlia ce b) s)
+let memo_nra = CacheQ.memo ".nra.cache" (fun (o,s) -> lift_pexpr_prover (Certificate.nlinear_prover o) s)
+
+
+ 
 let linear_prover_Q = {
-  name    = "linear prover";
-  prover  = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_spec) ;
-  hyps    = hyps_of_cone ;
-  compact = compact_cone ;
-  pp_prf  = pp_psatz pp_q ;
-  pp_f   = fun o x -> pp_pol pp_q o  (fst x)
+ name    = "linear prover";
+ get_option = get_lra_option ; 
+ prover  = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o Certificate.q_spec) l) ;
+ hyps    = hyps_of_cone ;
+ compact = compact_cone ;
+ pp_prf  = pp_psatz pp_q ;
+ pp_f   = fun o x -> pp_pol pp_q o  (fst x)
 }
 
 
 let linear_prover_R = {
   name    = "linear prover";
-  prover  = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_spec) ;
+ get_option = get_lra_option ; 
+ prover  = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o Certificate.q_spec) l) ;
   hyps    = hyps_of_cone ;
   compact = compact_cone ;
   pp_prf  = pp_psatz pp_q ;
   pp_f    =  fun o x -> pp_pol pp_q o (fst x)
 }
 
+let nlinear_prover_R = {
+  name    = "nra";
+ get_option = get_lra_option;
+ prover  = memo_nra ;
+  hyps    = hyps_of_cone ;
+  compact = compact_cone ;
+  pp_prf  = pp_psatz pp_q ;
+  pp_f    =  fun o x -> pp_pol pp_q o (fst x)
+}
 
 let non_linear_prover_Q str o = {
   name    = "real nonlinear prover";
-  prover  = call_csdpcert_q (str, o);
+ get_option = (fun () -> (str,o));
+ prover  = (fun (o,l) -> call_csdpcert_q o l);
   hyps    = hyps_of_cone;
   compact = compact_cone ;
   pp_prf  = pp_psatz pp_q ;
@@ -1938,7 +2355,8 @@ let non_linear_prover_Q str o = {
 
 let non_linear_prover_R str o = {
   name    = "real nonlinear prover";
-  prover  = call_csdpcert_q (str, o);
+ get_option = (fun () -> (str,o));
+ prover  = (fun (o,l) -> call_csdpcert_q o l);
   hyps    = hyps_of_cone;
   compact = compact_cone;
   pp_prf  = pp_psatz pp_q;
@@ -1947,30 +2365,18 @@ let non_linear_prover_R str o = {
 
 let non_linear_prover_Z str o  = {
   name    = "real nonlinear prover";
-  prover  = lift_ratproof (call_csdpcert_z (str, o));
+ get_option = (fun () -> (str,o));
+ prover  = (fun (o,l) -> lift_ratproof (call_csdpcert_z o) l);
   hyps    = hyps_of_pt;
   compact = compact_pt;
   pp_prf  = pp_proof_term;
   pp_f    =  fun o x -> pp_pol pp_z o (fst x)
 }
 
-module CacheZ = PHashtable(struct
-  type t = (Mc.z Mc.pol * Mc.op1) list
-  let equal = Pervasives.(=)
-  let hash  = Hashtbl.hash
-end)
-
-let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.lia)
-let memo_nlia = CacheZ.memo "nlia.cache" (lift_pexpr_prover Certificate.nlia)
-
-(*let memo_zlinear_prover = (lift_pexpr_prover Lia.lia)*)
-(*let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.zlinear_prover)*)
-
-
-
 let linear_Z =   {
   name    = "lia";
-  prover  = memo_zlinear_prover ;
+ get_option = get_lia_option;
+ prover  = memo_zlinear_prover ;
   hyps    = hyps_of_pt;
   compact = compact_pt;
   pp_prf  = pp_proof_term;
@@ -1979,7 +2385,8 @@ let linear_Z =   {
 
 let nlinear_Z =   {
   name    = "nlia";
-  prover  = memo_nlia ;
+ get_option = get_lia_option;
+ prover  = memo_nlia ;
   hyps    = hyps_of_pt;
   compact = compact_pt;
   pp_prf  = pp_proof_term;
@@ -2001,57 +2408,53 @@ let tauto_lia ff =
   * solvers
   *)
 
-let psatzl_Z gl =
- micromega_gen parse_zarith  Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
-  [ linear_prover_Z ] gl
-
-let psatzl_Q gl =
- micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec
-  [ linear_prover_Q ] gl
-
-let psatz_Q i gl =
- micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec
-  [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] gl
+let lra_Q =
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr
+  [ linear_prover_Q ] 
 
+let psatz_Q i  =
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr
+  [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ]
 
-let psatzl_R gl =
- micromega_genr [ linear_prover_R ] gl
+let lra_R  =
+ micromega_genr [ linear_prover_R ]
 
+let psatz_R i  =
+ micromega_genr  [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] 
 
-let psatz_R i gl =
- micromega_genr  [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] gl
 
+let psatz_Z i  =
+    micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr
+      [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] 
 
-let psatz_Z i gl =
-    micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
-      [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] gl
+let sos_Z  =
+ micromega_gen parse_zarith Mc.negate Mc.normalise  Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr
+  [ non_linear_prover_Z "pure_sos" None ] 
 
-let sos_Z gl =
- micromega_gen parse_zarith Mc.negate Mc.normalise  Mc.zunsat Mc.zdeduce zz_domain_spec
-  [ non_linear_prover_Z "pure_sos" None ] gl
+let sos_Q  =
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise  Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr
+  [ non_linear_prover_Q "pure_sos" None ] 
 
-let sos_Q gl =
- micromega_gen parse_qarith Mc.qnegate Mc.qnormalise  Mc.qunsat Mc.qdeduce qq_domain_spec
-  [ non_linear_prover_Q "pure_sos" None ] gl
 
+let sos_R  =
+ micromega_genr  [ non_linear_prover_R "pure_sos" None ] 
 
-let sos_R gl =
- micromega_genr  [ non_linear_prover_R "pure_sos" None ] gl
 
+let xlia  =  micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr
+      [ linear_Z ] 
 
-let xlia gl =
-  try 
-    micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
-      [ linear_Z ] gl
-  with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise
+let xnlia  =
+    micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr
+      [ nlinear_Z ] 
 
-let xnlia gl =
-  try 
-    micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
-      [ nlinear_Z ] gl
-  with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise
+let nra  = 
+ micromega_genr  [ nlinear_prover_R ] 
 
+let nqa  =
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr
+  [ nlinear_prover_R ]
 
+   
 
 (* Local Variables: *)
 (* coding: utf-8 *)
diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4
index 75237aaa..027f690f 100644
--- a/plugins/micromega/g_micromega.ml4
+++ b/plugins/micromega/g_micromega.ml4
@@ -16,63 +16,68 @@
 
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
-open Errors
-open Misctypes
+open Constrarg
 
 DECLARE PLUGIN "micromega_plugin"
 
-let out_arg = function
-  | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable")
-  | ArgArg x -> x
+TACTIC EXTEND RED
+| [ "myred"  ] -> [ Tactics.red_in_concl ]
+END
+
+
 
 TACTIC EXTEND PsatzZ
-| [ "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)) ]
+| [ "psatz_Z" int_or_var(i) tactic(t) ] -> [  (Coq_micromega.psatz_Z i
+                                               (Tacinterp.tactic_of_value ist t))
+                                               ]
+| [ "psatz_Z" tactic(t)] -> [  (Coq_micromega.psatz_Z (-1)) (Tacinterp.tactic_of_value ist t) ]
 END
 
 TACTIC EXTEND Lia
-[ "xlia"  ] -> [  Proofview.V82.tactic (Coq_micromega.xlia) ]
+[ "xlia" tactic(t) ] -> [   (Coq_micromega.xlia (Tacinterp.tactic_of_value ist t)) ]
 END
 
 TACTIC EXTEND Nia
-[ "xnlia"  ] -> [  Proofview.V82.tactic (Coq_micromega.xnlia) ]
+[ "xnlia" tactic(t) ] -> [  (Coq_micromega.xnlia (Tacinterp.tactic_of_value ist t)) ]
+END
+
+TACTIC EXTEND NRA
+[ "xnra" tactic(t) ] -> [  (Coq_micromega.nra (Tacinterp.tactic_of_value ist t))]
 END
 
+TACTIC EXTEND NQA
+[ "xnqa" tactic(t) ] -> [  (Coq_micromega.nqa (Tacinterp.tactic_of_value ist t))]
+END
 
 
+  
 TACTIC EXTEND Sos_Z
-| [ "sos_Z" ] -> [  Proofview.V82.tactic (Coq_micromega.sos_Z) ]
+| [ "sos_Z" tactic(t) ] -> [ (Coq_micromega.sos_Z (Tacinterp.tactic_of_value ist t)) ]
    END
 
 TACTIC EXTEND Sos_Q
-| [ "sos_Q" ] -> [  Proofview.V82.tactic (Coq_micromega.sos_Q) ]
+| [ "sos_Q" tactic(t) ] -> [   (Coq_micromega.sos_Q (Tacinterp.tactic_of_value ist t)) ]
    END
 
 TACTIC EXTEND Sos_R
-| [ "sos_R" ] -> [  Proofview.V82.tactic (Coq_micromega.sos_R) ]
-END
-
-(*
-TACTIC EXTEND Omicron
-[ "psatzl_Z"  ] -> [  Proofview.V82.tactic (Coq_micromega.psatzl_Z) ]
+| [ "sos_R" tactic(t) ] -> [   (Coq_micromega.sos_R (Tacinterp.tactic_of_value ist t)) ]
 END
-*)
 
 TACTIC EXTEND LRA_Q
-[ "psatzl_Q"  ] -> [  Proofview.V82.tactic (Coq_micromega.psatzl_Q) ]
+[ "lra_Q"  tactic(t) ] -> [   (Coq_micromega.lra_Q (Tacinterp.tactic_of_value ist t)) ]
 END
 
 TACTIC EXTEND LRA_R
-[ "psatzl_R"  ] -> [  Proofview.V82.tactic (Coq_micromega.psatzl_R) ]
+[ "lra_R" tactic(t) ] -> [   (Coq_micromega.lra_R (Tacinterp.tactic_of_value ist t)) ]
 END
 
 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)) ]
+| [ "psatz_R" int_or_var(i) tactic(t) ] -> [   (Coq_micromega.psatz_R i (Tacinterp.tactic_of_value ist t)) ]
+| [ "psatz_R" tactic(t) ] -> [   (Coq_micromega.psatz_R (-1) (Tacinterp.tactic_of_value ist t)) ]
 END
 
 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)) ]
+| [ "psatz_Q" int_or_var(i) tactic(t) ] -> [  (Coq_micromega.psatz_Q i (Tacinterp.tactic_of_value ist t)) ]
+| [ "psatz_Q" tactic(t) ] -> [  (Coq_micromega.psatz_Q (-1) (Tacinterp.tactic_of_value ist t)) ]
 END
 
diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml
index a36369d2..f4f9b3c2 100644
--- a/plugins/micromega/mfourier.ml
+++ b/plugins/micromega/mfourier.ml
@@ -98,12 +98,12 @@ module PSet = ISet
 
 module System = Hashtbl.Make(Vect)
 
-  type proof =
-      | Hyp of int
-      | Elim of  var * proof * proof
-      | And of proof * proof
-
+type proof =
+| Hyp of int
+| Elim of  var * proof * proof
+| And of proof * proof
 
+let max_nb_cstr = ref max_int
 
 type system = {
   sys : cstr_info ref System.t ;
@@ -120,7 +120,7 @@ and cstr_info = {
 (** 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.
+    - [prf_idx] is the set of hypothesis indexes (i.e. constraints in the initial system) used to obtain the current constraint.
        In the initial system, each constraint is given an unique singleton proof_idx.
        When a new constraint c is computed by a function f(c1,...,cn), its proof_idx is ISet.fold union (List.map (fun x -> x.proof_idx) [c1;...;cn]
     - [pos] is the number of positive values of the vector
@@ -208,8 +208,7 @@ let merge_cstr_info i1 i2 =
 *)
 
 let xadd_cstr vect cstr_info sys =
-  if debug && Int.equal (System.length sys mod 1000) 0 then (print_string "*" ; flush stdout) ;
-  try
+ try
     let info = System.find sys vect in
       match merge_cstr_info cstr_info !info with
 	  | None       -> raise (SystemContradiction  (And(cstr_info.prf, (!info).prf)))
@@ -217,6 +216,13 @@ let xadd_cstr vect cstr_info sys =
       with
 	| Not_found -> System.replace  sys vect (ref cstr_info)
 
+exception TimeOut
+         
+let xadd_cstr vect cstr_info sys = 
+  if debug && Int.equal (System.length sys mod 1000) 0 then (print_string "*" ; flush stdout) ;
+ if System.length sys < !max_nb_cstr
+ then xadd_cstr vect cstr_info sys
+ else raise TimeOut
 
 type cstr_ext =
     | Contradiction (** The constraint is contradictory.
@@ -728,7 +734,7 @@ struct
 	| Inl (s,_) ->
 	    try
 	      Some (bound_of_variable IMap.empty fresh s.sys)
-	    with x when Errors.noncritical x ->
+	    with x when CErrors.noncritical x ->
 	      Printf.printf "optimise Exception : %s" (Printexc.to_string x);
               None
 
@@ -866,7 +872,7 @@ let  mk_proof hyps prf =
       | Elim(v,prf1,prf2) ->
           let prfsl = mk_proof prf1
           and prfsr = mk_proof prf2 in
-            (* I take only the pairs for which the elimination is meaningfull *)
+            (* I take only the pairs for which the elimination is meaningful *)
             forall_pairs (pivot v) prfsl prfsr
       | And(prf1,prf2) ->
           let prfsl1 = mk_proof prf1
diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml
index 0537cdbe..5cf1da8e 100644
--- a/plugins/micromega/micromega.ml
+++ b/plugins/micromega/micromega.ml
@@ -1,6 +1,3 @@
-type __ = Obj.t
-let __ = let rec f _ = Obj.repr f in Obj.repr f
-
 (** val negb : bool -> bool **)
 
 let negb = function
@@ -11,16 +8,6 @@ type nat =
 | O
 | S of nat
 
-(** val fst : ('a1 * 'a2) -> 'a1 **)
-
-let fst = function
-| x,y -> x
-
-(** val snd : ('a1 * 'a2) -> 'a2 **)
-
-let snd = function
-| x,y -> y
-
 (** val app : 'a1 list -> 'a1 list -> 'a1 list **)
 
 let rec app l m =
@@ -40,42 +27,15 @@ let compOpp = function
 | Lt -> Gt
 | Gt -> Lt
 
-type compareSpecT =
-| CompEqT
-| CompLtT
-| CompGtT
-
-(** val compareSpec2Type : comparison -> compareSpecT **)
-
-let compareSpec2Type = function
-| Eq -> CompEqT
-| Lt -> CompLtT
-| Gt -> CompGtT
-
-type 'a compSpecT = compareSpecT
-
-(** val compSpec2Type : 'a1 -> 'a1 -> comparison -> 'a1 compSpecT **)
-
-let compSpec2Type x y c =
-  compareSpec2Type c
-
-type 'a sig0 =
-  'a
-  (* singleton inductive, whose constructor was exist *)
-
-(** val plus : nat -> nat -> nat **)
-
-let rec plus n0 m =
-  match n0 with
-  | O -> m
-  | S p -> S (plus p m)
-
-(** val nat_iter : nat -> ('a1 -> 'a1) -> 'a1 -> 'a1 **)
+module Coq__1 = struct
+ (** val add : nat -> nat -> nat **)
+ let rec add n0 m =
+   match n0 with
+   | O -> m
+   | S p -> S (add p m)
+end
+let add = Coq__1.add
 
-let rec nat_iter n0 f x =
-  match n0 with
-  | O -> x
-  | S n' -> f (nat_iter n' f x)
 
 type positive =
 | XI of positive
@@ -91,592 +51,25 @@ type z =
 | Zpos of positive
 | Zneg of positive
 
-module type TotalOrder' = 
- sig 
-  type t 
- end
-
-module MakeOrderTac = 
- functor (O:TotalOrder') ->
- struct 
-  
- end
-
-module MaxLogicalProperties = 
- functor (O:TotalOrder') ->
- functor (M:sig 
-  val max : O.t -> O.t -> O.t
- end) ->
- struct 
-  module T = MakeOrderTac(O)
- end
-
-module Pos = 
- struct 
-  type t = positive
-  
-  (** val succ : positive -> positive **)
-  
-  let rec succ = function
-  | XI p -> XO (succ p)
-  | XO p -> XI p
-  | XH -> XO XH
-  
-  (** val add : positive -> positive -> positive **)
-  
-  let rec add x y =
-    match x with
-    | XI p ->
-      (match y with
-       | XI q0 -> XO (add_carry p q0)
-       | XO q0 -> XI (add p q0)
-       | XH -> XO (succ p))
-    | XO p ->
-      (match y with
-       | XI q0 -> XI (add p q0)
-       | XO q0 -> XO (add p q0)
-       | XH -> XI p)
-    | XH ->
-      (match y with
-       | XI q0 -> XO (succ q0)
-       | XO q0 -> XI q0
-       | XH -> XO XH)
-  
-  (** val add_carry : positive -> positive -> positive **)
-  
-  and add_carry x y =
-    match x with
-    | XI p ->
-      (match y with
-       | XI q0 -> XI (add_carry p q0)
-       | XO q0 -> XO (add_carry p q0)
-       | XH -> XI (succ p))
-    | XO p ->
-      (match y with
-       | XI q0 -> XO (add_carry p q0)
-       | XO q0 -> XI (add p q0)
-       | XH -> XO (succ p))
-    | XH ->
-      (match y with
-       | XI q0 -> XI (succ q0)
-       | XO q0 -> XO (succ q0)
-       | XH -> XI XH)
-  
-  (** val pred_double : positive -> positive **)
-  
-  let rec pred_double = function
-  | XI p -> XI (XO p)
-  | XO p -> XI (pred_double p)
-  | XH -> XH
-  
-  (** val pred : positive -> positive **)
-  
-  let pred = function
-  | XI p -> XO p
-  | XO p -> pred_double p
-  | XH -> XH
-  
-  (** val pred_N : positive -> n **)
-  
-  let pred_N = function
-  | XI p -> Npos (XO p)
-  | XO p -> Npos (pred_double p)
-  | XH -> N0
-  
+module Pos =
+ struct
   type mask =
   | IsNul
   | IsPos of positive
   | IsNeg
-  
-  (** val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **)
-  
-  let mask_rect f f0 f1 = function
-  | IsNul -> f
-  | IsPos x -> f0 x
-  | IsNeg -> f1
-  
-  (** val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **)
-  
-  let mask_rec f f0 f1 = function
-  | IsNul -> f
-  | IsPos x -> f0 x
-  | IsNeg -> f1
-  
-  (** val succ_double_mask : mask -> mask **)
-  
-  let succ_double_mask = function
-  | IsNul -> IsPos XH
-  | IsPos p -> IsPos (XI p)
-  | IsNeg -> IsNeg
-  
-  (** val double_mask : mask -> mask **)
-  
-  let double_mask = function
-  | IsPos p -> IsPos (XO p)
-  | x0 -> x0
-  
-  (** val double_pred_mask : positive -> mask **)
-  
-  let double_pred_mask = function
-  | XI p -> IsPos (XO (XO p))
-  | XO p -> IsPos (XO (pred_double p))
-  | XH -> IsNul
-  
-  (** val pred_mask : mask -> mask **)
-  
-  let pred_mask = function
-  | IsPos q0 ->
-    (match q0 with
-     | XH -> IsNul
-     | _ -> IsPos (pred q0))
-  | _ -> IsNeg
-  
-  (** val sub_mask : positive -> positive -> mask **)
-  
-  let rec sub_mask x y =
-    match x with
-    | XI p ->
-      (match y with
-       | XI q0 -> double_mask (sub_mask p q0)
-       | XO q0 -> succ_double_mask (sub_mask p q0)
-       | XH -> IsPos (XO p))
-    | XO p ->
-      (match y with
-       | XI q0 -> succ_double_mask (sub_mask_carry p q0)
-       | XO q0 -> double_mask (sub_mask p q0)
-       | XH -> IsPos (pred_double p))
-    | XH ->
-      (match y with
-       | XH -> IsNul
-       | _ -> IsNeg)
-  
-  (** val sub_mask_carry : positive -> positive -> mask **)
-  
-  and sub_mask_carry x y =
-    match x with
-    | XI p ->
-      (match y with
-       | XI q0 -> succ_double_mask (sub_mask_carry p q0)
-       | XO q0 -> double_mask (sub_mask p q0)
-       | XH -> IsPos (pred_double p))
-    | XO p ->
-      (match y with
-       | XI q0 -> double_mask (sub_mask_carry p q0)
-       | XO q0 -> succ_double_mask (sub_mask_carry p q0)
-       | XH -> double_pred_mask p)
-    | XH -> IsNeg
-  
-  (** val sub : positive -> positive -> positive **)
-  
-  let sub x y =
-    match sub_mask x y with
-    | IsPos z0 -> z0
-    | _ -> XH
-  
-  (** val mul : positive -> positive -> positive **)
-  
-  let rec mul x y =
-    match x with
-    | XI p -> add y (XO (mul p y))
-    | XO p -> XO (mul p y)
-    | XH -> y
-  
-  (** val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 **)
-  
-  let rec iter n0 f x =
-    match n0 with
-    | XI n' -> f (iter n' f (iter n' f x))
-    | XO n' -> iter n' f (iter n' f x)
-    | XH -> f x
-  
-  (** val pow : positive -> positive -> positive **)
-  
-  let pow x y =
-    iter y (mul x) XH
-  
-  (** val div2 : positive -> positive **)
-  
-  let div2 = function
-  | XI p2 -> p2
-  | XO p2 -> p2
-  | XH -> XH
-  
-  (** val div2_up : positive -> positive **)
-  
-  let div2_up = function
-  | XI p2 -> succ p2
-  | XO p2 -> p2
-  | XH -> XH
-  
-  (** val size_nat : positive -> nat **)
-  
-  let rec size_nat = function
-  | XI p2 -> S (size_nat p2)
-  | XO p2 -> S (size_nat p2)
-  | XH -> S O
-  
-  (** val size : positive -> positive **)
-  
-  let rec size = function
-  | XI p2 -> succ (size p2)
-  | XO p2 -> succ (size p2)
-  | XH -> XH
-  
-  (** val compare_cont : positive -> positive -> comparison -> comparison **)
-  
-  let rec compare_cont x y r =
-    match x with
-    | XI p ->
-      (match y with
-       | XI q0 -> compare_cont p q0 r
-       | XO q0 -> compare_cont p q0 Gt
-       | XH -> Gt)
-    | XO p ->
-      (match y with
-       | XI q0 -> compare_cont p q0 Lt
-       | XO q0 -> compare_cont p q0 r
-       | XH -> Gt)
-    | XH ->
-      (match y with
-       | XH -> r
-       | _ -> Lt)
-  
-  (** val compare : positive -> positive -> comparison **)
-  
-  let compare x y =
-    compare_cont x y Eq
-  
-  (** val min : positive -> positive -> positive **)
-  
-  let min p p' =
-    match compare p p' with
-    | Gt -> p'
-    | _ -> p
-  
-  (** val max : positive -> positive -> positive **)
-  
-  let max p p' =
-    match compare p p' with
-    | Gt -> p
-    | _ -> p'
-  
-  (** val eqb : positive -> positive -> bool **)
-  
-  let rec eqb p q0 =
-    match p with
-    | XI p2 ->
-      (match q0 with
-       | XI q1 -> eqb p2 q1
-       | _ -> false)
-    | XO p2 ->
-      (match q0 with
-       | XO q1 -> eqb p2 q1
-       | _ -> false)
-    | XH ->
-      (match q0 with
-       | XH -> true
-       | _ -> false)
-  
-  (** val leb : positive -> positive -> bool **)
-  
-  let leb x y =
-    match compare x y with
-    | Gt -> false
-    | _ -> true
-  
-  (** val ltb : positive -> positive -> bool **)
-  
-  let ltb x y =
-    match compare x y with
-    | Lt -> true
-    | _ -> false
-  
-  (** val sqrtrem_step :
-      (positive -> positive) -> (positive -> positive) -> (positive * mask)
-      -> positive * mask **)
-  
-  let sqrtrem_step f g = function
-  | s,y ->
-    (match y with
-     | IsPos r ->
-       let s' = XI (XO s) in
-       let r' = g (f r) in
-       if leb s' r' then (XI s),(sub_mask r' s') else (XO s),(IsPos r')
-     | _ -> (XO s),(sub_mask (g (f XH)) (XO (XO XH))))
-  
-  (** val sqrtrem : positive -> positive * mask **)
-  
-  let rec sqrtrem = function
-  | XI p2 ->
-    (match p2 with
-     | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XI x) (sqrtrem p3)
-     | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XI x) (sqrtrem p3)
-     | XH -> XH,(IsPos (XO XH)))
-  | XO p2 ->
-    (match p2 with
-     | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XO x) (sqrtrem p3)
-     | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XO x) (sqrtrem p3)
-     | XH -> XH,(IsPos XH))
-  | XH -> XH,IsNul
-  
-  (** val sqrt : positive -> positive **)
-  
-  let sqrt p =
-    fst (sqrtrem p)
-  
-  (** val gcdn : nat -> positive -> positive -> positive **)
-  
-  let rec gcdn n0 a b =
-    match n0 with
-    | O -> XH
-    | S n1 ->
-      (match a with
-       | XI a' ->
-         (match b with
-          | XI b' ->
-            (match compare a' b' with
-             | Eq -> a
-             | Lt -> gcdn n1 (sub b' a') a
-             | Gt -> gcdn n1 (sub a' b') b)
-          | XO b0 -> gcdn n1 a b0
-          | XH -> XH)
-       | XO a0 ->
-         (match b with
-          | XI p -> gcdn n1 a0 b
-          | XO b0 -> XO (gcdn n1 a0 b0)
-          | XH -> XH)
-       | XH -> XH)
-  
-  (** val gcd : positive -> positive -> positive **)
-  
-  let gcd a b =
-    gcdn (plus (size_nat a) (size_nat b)) a b
-  
-  (** val ggcdn :
-      nat -> positive -> positive -> positive * (positive * positive) **)
-  
-  let rec ggcdn n0 a b =
-    match n0 with
-    | O -> XH,(a,b)
-    | S n1 ->
-      (match a with
-       | XI a' ->
-         (match b with
-          | XI b' ->
-            (match compare a' b' with
-             | Eq -> a,(XH,XH)
-             | Lt ->
-               let g,p = ggcdn n1 (sub b' a') a in
-               let ba,aa = p in g,(aa,(add aa (XO ba)))
-             | Gt ->
-               let g,p = ggcdn n1 (sub a' b') b in
-               let ab,bb = p in g,((add bb (XO ab)),bb))
-          | XO b0 ->
-            let g,p = ggcdn n1 a b0 in let aa,bb = p in g,(aa,(XO bb))
-          | XH -> XH,(a,XH))
-       | XO a0 ->
-         (match b with
-          | XI p ->
-            let g,p2 = ggcdn n1 a0 b in let aa,bb = p2 in g,((XO aa),bb)
-          | XO b0 -> let g,p = ggcdn n1 a0 b0 in (XO g),p
-          | XH -> XH,(a,XH))
-       | XH -> XH,(XH,b))
-  
-  (** val ggcd : positive -> positive -> positive * (positive * positive) **)
-  
-  let ggcd a b =
-    ggcdn (plus (size_nat a) (size_nat b)) a b
-  
-  (** val coq_Nsucc_double : n -> n **)
-  
-  let coq_Nsucc_double = function
-  | N0 -> Npos XH
-  | Npos p -> Npos (XI p)
-  
-  (** val coq_Ndouble : n -> n **)
-  
-  let coq_Ndouble = function
-  | N0 -> N0
-  | Npos p -> Npos (XO p)
-  
-  (** val coq_lor : positive -> positive -> positive **)
-  
-  let rec coq_lor p q0 =
-    match p with
-    | XI p2 ->
-      (match q0 with
-       | XI q1 -> XI (coq_lor p2 q1)
-       | XO q1 -> XI (coq_lor p2 q1)
-       | XH -> p)
-    | XO p2 ->
-      (match q0 with
-       | XI q1 -> XI (coq_lor p2 q1)
-       | XO q1 -> XO (coq_lor p2 q1)
-       | XH -> XI p2)
-    | XH ->
-      (match q0 with
-       | XO q1 -> XI q1
-       | _ -> q0)
-  
-  (** val coq_land : positive -> positive -> n **)
-  
-  let rec coq_land p q0 =
-    match p with
-    | XI p2 ->
-      (match q0 with
-       | XI q1 -> coq_Nsucc_double (coq_land p2 q1)
-       | XO q1 -> coq_Ndouble (coq_land p2 q1)
-       | XH -> Npos XH)
-    | XO p2 ->
-      (match q0 with
-       | XI q1 -> coq_Ndouble (coq_land p2 q1)
-       | XO q1 -> coq_Ndouble (coq_land p2 q1)
-       | XH -> N0)
-    | XH ->
-      (match q0 with
-       | XO q1 -> N0
-       | _ -> Npos XH)
-  
-  (** val ldiff : positive -> positive -> n **)
-  
-  let rec ldiff p q0 =
-    match p with
-    | XI p2 ->
-      (match q0 with
-       | XI q1 -> coq_Ndouble (ldiff p2 q1)
-       | XO q1 -> coq_Nsucc_double (ldiff p2 q1)
-       | XH -> Npos (XO p2))
-    | XO p2 ->
-      (match q0 with
-       | XI q1 -> coq_Ndouble (ldiff p2 q1)
-       | XO q1 -> coq_Ndouble (ldiff p2 q1)
-       | XH -> Npos p)
-    | XH ->
-      (match q0 with
-       | XO q1 -> Npos XH
-       | _ -> N0)
-  
-  (** val coq_lxor : positive -> positive -> n **)
-  
-  let rec coq_lxor p q0 =
-    match p with
-    | XI p2 ->
-      (match q0 with
-       | XI q1 -> coq_Ndouble (coq_lxor p2 q1)
-       | XO q1 -> coq_Nsucc_double (coq_lxor p2 q1)
-       | XH -> Npos (XO p2))
-    | XO p2 ->
-      (match q0 with
-       | XI q1 -> coq_Nsucc_double (coq_lxor p2 q1)
-       | XO q1 -> coq_Ndouble (coq_lxor p2 q1)
-       | XH -> Npos (XI p2))
-    | XH ->
-      (match q0 with
-       | XI q1 -> Npos (XO q1)
-       | XO q1 -> Npos (XI q1)
-       | XH -> N0)
-  
-  (** val shiftl_nat : positive -> nat -> positive **)
-  
-  let shiftl_nat p n0 =
-    nat_iter n0 (fun x -> XO x) p
-  
-  (** val shiftr_nat : positive -> nat -> positive **)
-  
-  let shiftr_nat p n0 =
-    nat_iter n0 div2 p
-  
-  (** val shiftl : positive -> n -> positive **)
-  
-  let shiftl p = function
-  | N0 -> p
-  | Npos n1 -> iter n1 (fun x -> XO x) p
-  
-  (** val shiftr : positive -> n -> positive **)
-  
-  let shiftr p = function
-  | N0 -> p
-  | Npos n1 -> iter n1 div2 p
-  
-  (** val testbit_nat : positive -> nat -> bool **)
-  
-  let rec testbit_nat p n0 =
-    match p with
-    | XI p2 ->
-      (match n0 with
-       | O -> true
-       | S n' -> testbit_nat p2 n')
-    | XO p2 ->
-      (match n0 with
-       | O -> false
-       | S n' -> testbit_nat p2 n')
-    | XH ->
-      (match n0 with
-       | O -> true
-       | S n1 -> false)
-  
-  (** val testbit : positive -> n -> bool **)
-  
-  let rec testbit p n0 =
-    match p with
-    | XI p2 ->
-      (match n0 with
-       | N0 -> true
-       | Npos n1 -> testbit p2 (pred_N n1))
-    | XO p2 ->
-      (match n0 with
-       | N0 -> false
-       | Npos n1 -> testbit p2 (pred_N n1))
-    | XH ->
-      (match n0 with
-       | N0 -> true
-       | Npos p2 -> false)
-  
-  (** val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 **)
-  
-  let rec iter_op op p a =
-    match p with
-    | XI p2 -> op a (iter_op op p2 (op a a))
-    | XO p2 -> iter_op op p2 (op a a)
-    | XH -> a
-  
-  (** val to_nat : positive -> nat **)
-  
-  let to_nat x =
-    iter_op plus x (S O)
-  
-  (** val of_nat : nat -> positive **)
-  
-  let rec of_nat = function
-  | O -> XH
-  | S x ->
-    (match x with
-     | O -> XH
-     | S n1 -> succ (of_nat x))
-  
-  (** val of_succ_nat : nat -> positive **)
-  
-  let rec of_succ_nat = function
-  | O -> XH
-  | S x -> succ (of_succ_nat x)
  end
 
-module Coq_Pos = 
- struct 
-  module Coq__1 = struct 
-   type t = positive
-  end
-  type t = Coq__1.t
-  
+module Coq_Pos =
+ struct
   (** val succ : positive -> positive **)
-  
+
   let rec succ = function
   | XI p -> XO (succ p)
   | XO p -> XI p
   | XH -> XO XH
-  
+
   (** val add : positive -> positive -> positive **)
-  
+
   let rec add x y =
     match x with
     | XI p ->
@@ -694,9 +87,9 @@ module Coq_Pos =
        | XI q0 -> XO (succ q0)
        | XO q0 -> XI q0
        | XH -> XO XH)
-  
+
   (** val add_carry : positive -> positive -> positive **)
-  
+
   and add_carry x y =
     match x with
     | XI p ->
@@ -714,78 +107,41 @@ module Coq_Pos =
        | XI q0 -> XI (succ q0)
        | XO q0 -> XO (succ q0)
        | XH -> XI XH)
-  
+
   (** val pred_double : positive -> positive **)
-  
+
   let rec pred_double = function
   | XI p -> XI (XO p)
   | XO p -> XI (pred_double p)
   | XH -> XH
-  
-  (** val pred : positive -> positive **)
-  
-  let pred = function
-  | XI p -> XO p
-  | XO p -> pred_double p
-  | XH -> XH
-  
-  (** val pred_N : positive -> n **)
-  
-  let pred_N = function
-  | XI p -> Npos (XO p)
-  | XO p -> Npos (pred_double p)
-  | XH -> N0
-  
+
   type mask = Pos.mask =
   | IsNul
   | IsPos of positive
   | IsNeg
-  
-  (** val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **)
-  
-  let mask_rect f f0 f1 = function
-  | IsNul -> f
-  | IsPos x -> f0 x
-  | IsNeg -> f1
-  
-  (** val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **)
-  
-  let mask_rec f f0 f1 = function
-  | IsNul -> f
-  | IsPos x -> f0 x
-  | IsNeg -> f1
-  
+
   (** val succ_double_mask : mask -> mask **)
-  
+
   let succ_double_mask = function
   | IsNul -> IsPos XH
   | IsPos p -> IsPos (XI p)
   | IsNeg -> IsNeg
-  
+
   (** val double_mask : mask -> mask **)
-  
+
   let double_mask = function
   | IsPos p -> IsPos (XO p)
   | x0 -> x0
-  
+
   (** val double_pred_mask : positive -> mask **)
-  
+
   let double_pred_mask = function
   | XI p -> IsPos (XO (XO p))
   | XO p -> IsPos (XO (pred_double p))
   | XH -> IsNul
-  
-  (** val pred_mask : mask -> mask **)
-  
-  let pred_mask = function
-  | IsPos q0 ->
-    (match q0 with
-     | XH -> IsNul
-     | _ -> IsPos (pred q0))
-  | _ -> IsNeg
-  
+
   (** val sub_mask : positive -> positive -> mask **)
-  
+
   let rec sub_mask x y =
     match x with
     | XI p ->
@@ -802,9 +158,9 @@ module Coq_Pos =
       (match y with
        | XH -> IsNul
        | _ -> IsNeg)
-  
+
   (** val sub_mask_carry : positive -> positive -> mask **)
-  
+
   and sub_mask_carry x y =
     match x with
     | XI p ->
@@ -818,167 +174,56 @@ module Coq_Pos =
        | XO q0 -> succ_double_mask (sub_mask_carry p q0)
        | XH -> double_pred_mask p)
     | XH -> IsNeg
-  
+
   (** val sub : positive -> positive -> positive **)
-  
+
   let sub x y =
     match sub_mask x y with
     | IsPos z0 -> z0
     | _ -> XH
-  
+
   (** val mul : positive -> positive -> positive **)
-  
+
   let rec mul x y =
     match x with
     | XI p -> add y (XO (mul p y))
     | XO p -> XO (mul p y)
     | XH -> y
-  
-  (** val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 **)
-  
-  let rec iter n0 f x =
-    match n0 with
-    | XI n' -> f (iter n' f (iter n' f x))
-    | XO n' -> iter n' f (iter n' f x)
-    | XH -> f x
-  
-  (** val pow : positive -> positive -> positive **)
-  
-  let pow x y =
-    iter y (mul x) XH
-  
-  (** val div2 : positive -> positive **)
-  
-  let div2 = function
-  | XI p2 -> p2
-  | XO p2 -> p2
-  | XH -> XH
-  
-  (** val div2_up : positive -> positive **)
-  
-  let div2_up = function
-  | XI p2 -> succ p2
-  | XO p2 -> p2
-  | XH -> XH
-  
+
   (** val size_nat : positive -> nat **)
-  
+
   let rec size_nat = function
   | XI p2 -> S (size_nat p2)
   | XO p2 -> S (size_nat p2)
   | XH -> S O
-  
-  (** val size : positive -> positive **)
-  
-  let rec size = function
-  | XI p2 -> succ (size p2)
-  | XO p2 -> succ (size p2)
-  | XH -> XH
-  
-  (** val compare_cont : positive -> positive -> comparison -> comparison **)
-  
-  let rec compare_cont x y r =
+
+  (** val compare_cont :
+      comparison -> positive -> positive -> comparison **)
+
+  let rec compare_cont r x y =
     match x with
     | XI p ->
       (match y with
-       | XI q0 -> compare_cont p q0 r
-       | XO q0 -> compare_cont p q0 Gt
+       | XI q0 -> compare_cont r p q0
+       | XO q0 -> compare_cont Gt p q0
        | XH -> Gt)
     | XO p ->
       (match y with
-       | XI q0 -> compare_cont p q0 Lt
-       | XO q0 -> compare_cont p q0 r
+       | XI q0 -> compare_cont Lt p q0
+       | XO q0 -> compare_cont r p q0
        | XH -> Gt)
     | XH ->
       (match y with
        | XH -> r
        | _ -> Lt)
-  
+
   (** val compare : positive -> positive -> comparison **)
-  
-  let compare x y =
-    compare_cont x y Eq
-  
-  (** val min : positive -> positive -> positive **)
-  
-  let min p p' =
-    match compare p p' with
-    | Gt -> p'
-    | _ -> p
-  
-  (** val max : positive -> positive -> positive **)
-  
-  let max p p' =
-    match compare p p' with
-    | Gt -> p
-    | _ -> p'
-  
-  (** val eqb : positive -> positive -> bool **)
-  
-  let rec eqb p q0 =
-    match p with
-    | XI p2 ->
-      (match q0 with
-       | XI q1 -> eqb p2 q1
-       | _ -> false)
-    | XO p2 ->
-      (match q0 with
-       | XO q1 -> eqb p2 q1
-       | _ -> false)
-    | XH ->
-      (match q0 with
-       | XH -> true
-       | _ -> false)
-  
-  (** val leb : positive -> positive -> bool **)
-  
-  let leb x y =
-    match compare x y with
-    | Gt -> false
-    | _ -> true
-  
-  (** val ltb : positive -> positive -> bool **)
-  
-  let ltb x y =
-    match compare x y with
-    | Lt -> true
-    | _ -> false
-  
-  (** val sqrtrem_step :
-      (positive -> positive) -> (positive -> positive) -> (positive * mask)
-      -> positive * mask **)
-  
-  let sqrtrem_step f g = function
-  | s,y ->
-    (match y with
-     | IsPos r ->
-       let s' = XI (XO s) in
-       let r' = g (f r) in
-       if leb s' r' then (XI s),(sub_mask r' s') else (XO s),(IsPos r')
-     | _ -> (XO s),(sub_mask (g (f XH)) (XO (XO XH))))
-  
-  (** val sqrtrem : positive -> positive * mask **)
-  
-  let rec sqrtrem = function
-  | XI p2 ->
-    (match p2 with
-     | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XI x) (sqrtrem p3)
-     | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XI x) (sqrtrem p3)
-     | XH -> XH,(IsPos (XO XH)))
-  | XO p2 ->
-    (match p2 with
-     | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XO x) (sqrtrem p3)
-     | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XO x) (sqrtrem p3)
-     | XH -> XH,(IsPos XH))
-  | XH -> XH,IsNul
-  
-  (** val sqrt : positive -> positive **)
-  
-  let sqrt p =
-    fst (sqrtrem p)
-  
+
+  let compare =
+    compare_cont Eq
+
   (** val gcdn : nat -> positive -> positive -> positive **)
-  
+
   let rec gcdn n0 a b =
     match n0 with
     | O -> XH
@@ -995,1001 +240,30 @@ module Coq_Pos =
           | XH -> XH)
        | XO a0 ->
          (match b with
-          | XI p -> gcdn n1 a0 b
+          | XI _ -> gcdn n1 a0 b
           | XO b0 -> XO (gcdn n1 a0 b0)
           | XH -> XH)
        | XH -> XH)
-  
+
   (** val gcd : positive -> positive -> positive **)
-  
+
   let gcd a b =
-    gcdn (plus (size_nat a) (size_nat b)) a b
-  
-  (** val ggcdn :
-      nat -> positive -> positive -> positive * (positive * positive) **)
-  
-  let rec ggcdn n0 a b =
-    match n0 with
-    | O -> XH,(a,b)
-    | S n1 ->
-      (match a with
-       | XI a' ->
-         (match b with
-          | XI b' ->
-            (match compare a' b' with
-             | Eq -> a,(XH,XH)
-             | Lt ->
-               let g,p = ggcdn n1 (sub b' a') a in
-               let ba,aa = p in g,(aa,(add aa (XO ba)))
-             | Gt ->
-               let g,p = ggcdn n1 (sub a' b') b in
-               let ab,bb = p in g,((add bb (XO ab)),bb))
-          | XO b0 ->
-            let g,p = ggcdn n1 a b0 in let aa,bb = p in g,(aa,(XO bb))
-          | XH -> XH,(a,XH))
-       | XO a0 ->
-         (match b with
-          | XI p ->
-            let g,p2 = ggcdn n1 a0 b in let aa,bb = p2 in g,((XO aa),bb)
-          | XO b0 -> let g,p = ggcdn n1 a0 b0 in (XO g),p
-          | XH -> XH,(a,XH))
-       | XH -> XH,(XH,b))
-  
-  (** val ggcd : positive -> positive -> positive * (positive * positive) **)
-  
-  let ggcd a b =
-    ggcdn (plus (size_nat a) (size_nat b)) a b
-  
-  (** val coq_Nsucc_double : n -> n **)
-  
-  let coq_Nsucc_double = function
-  | N0 -> Npos XH
-  | Npos p -> Npos (XI p)
-  
-  (** val coq_Ndouble : n -> n **)
-  
-  let coq_Ndouble = function
-  | N0 -> N0
-  | Npos p -> Npos (XO p)
-  
-  (** val coq_lor : positive -> positive -> positive **)
-  
-  let rec coq_lor p q0 =
-    match p with
-    | XI p2 ->
-      (match q0 with
-       | XI q1 -> XI (coq_lor p2 q1)
-       | XO q1 -> XI (coq_lor p2 q1)
-       | XH -> p)
-    | XO p2 ->
-      (match q0 with
-       | XI q1 -> XI (coq_lor p2 q1)
-       | XO q1 -> XO (coq_lor p2 q1)
-       | XH -> XI p2)
-    | XH ->
-      (match q0 with
-       | XO q1 -> XI q1
-       | _ -> q0)
-  
-  (** val coq_land : positive -> positive -> n **)
-  
-  let rec coq_land p q0 =
-    match p with
-    | XI p2 ->
-      (match q0 with
-       | XI q1 -> coq_Nsucc_double (coq_land p2 q1)
-       | XO q1 -> coq_Ndouble (coq_land p2 q1)
-       | XH -> Npos XH)
-    | XO p2 ->
-      (match q0 with
-       | XI q1 -> coq_Ndouble (coq_land p2 q1)
-       | XO q1 -> coq_Ndouble (coq_land p2 q1)
-       | XH -> N0)
-    | XH ->
-      (match q0 with
-       | XO q1 -> N0
-       | _ -> Npos XH)
-  
-  (** val ldiff : positive -> positive -> n **)
-  
-  let rec ldiff p q0 =
-    match p with
-    | XI p2 ->
-      (match q0 with
-       | XI q1 -> coq_Ndouble (ldiff p2 q1)
-       | XO q1 -> coq_Nsucc_double (ldiff p2 q1)
-       | XH -> Npos (XO p2))
-    | XO p2 ->
-      (match q0 with
-       | XI q1 -> coq_Ndouble (ldiff p2 q1)
-       | XO q1 -> coq_Ndouble (ldiff p2 q1)
-       | XH -> Npos p)
-    | XH ->
-      (match q0 with
-       | XO q1 -> Npos XH
-       | _ -> N0)
-  
-  (** val coq_lxor : positive -> positive -> n **)
-  
-  let rec coq_lxor p q0 =
-    match p with
-    | XI p2 ->
-      (match q0 with
-       | XI q1 -> coq_Ndouble (coq_lxor p2 q1)
-       | XO q1 -> coq_Nsucc_double (coq_lxor p2 q1)
-       | XH -> Npos (XO p2))
-    | XO p2 ->
-      (match q0 with
-       | XI q1 -> coq_Nsucc_double (coq_lxor p2 q1)
-       | XO q1 -> coq_Ndouble (coq_lxor p2 q1)
-       | XH -> Npos (XI p2))
-    | XH ->
-      (match q0 with
-       | XI q1 -> Npos (XO q1)
-       | XO q1 -> Npos (XI q1)
-       | XH -> N0)
-  
-  (** val shiftl_nat : positive -> nat -> positive **)
-  
-  let shiftl_nat p n0 =
-    nat_iter n0 (fun x -> XO x) p
-  
-  (** val shiftr_nat : positive -> nat -> positive **)
-  
-  let shiftr_nat p n0 =
-    nat_iter n0 div2 p
-  
-  (** val shiftl : positive -> n -> positive **)
-  
-  let shiftl p = function
-  | N0 -> p
-  | Npos n1 -> iter n1 (fun x -> XO x) p
-  
-  (** val shiftr : positive -> n -> positive **)
-  
-  let shiftr p = function
-  | N0 -> p
-  | Npos n1 -> iter n1 div2 p
-  
-  (** val testbit_nat : positive -> nat -> bool **)
-  
-  let rec testbit_nat p n0 =
-    match p with
-    | XI p2 ->
-      (match n0 with
-       | O -> true
-       | S n' -> testbit_nat p2 n')
-    | XO p2 ->
-      (match n0 with
-       | O -> false
-       | S n' -> testbit_nat p2 n')
-    | XH ->
-      (match n0 with
-       | O -> true
-       | S n1 -> false)
-  
-  (** val testbit : positive -> n -> bool **)
-  
-  let rec testbit p n0 =
-    match p with
-    | XI p2 ->
-      (match n0 with
-       | N0 -> true
-       | Npos n1 -> testbit p2 (pred_N n1))
-    | XO p2 ->
-      (match n0 with
-       | N0 -> false
-       | Npos n1 -> testbit p2 (pred_N n1))
-    | XH ->
-      (match n0 with
-       | N0 -> true
-       | Npos p2 -> false)
-  
-  (** val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 **)
-  
-  let rec iter_op op p a =
-    match p with
-    | XI p2 -> op a (iter_op op p2 (op a a))
-    | XO p2 -> iter_op op p2 (op a a)
-    | XH -> a
-  
-  (** val to_nat : positive -> nat **)
-  
-  let to_nat x =
-    iter_op plus x (S O)
-  
-  (** val of_nat : nat -> positive **)
-  
-  let rec of_nat = function
-  | O -> XH
-  | S x ->
-    (match x with
-     | O -> XH
-     | S n1 -> succ (of_nat x))
-  
+    gcdn (Coq__1.add (size_nat a) (size_nat b)) a b
+
   (** val of_succ_nat : nat -> positive **)
-  
+
   let rec of_succ_nat = function
   | O -> XH
   | S x -> succ (of_succ_nat x)
-  
-  (** val eq_dec : positive -> positive -> bool **)
-  
-  let rec eq_dec p y0 =
-    match p with
-    | XI p2 ->
-      (match y0 with
-       | XI p3 -> eq_dec p2 p3
-       | _ -> false)
-    | XO p2 ->
-      (match y0 with
-       | XO p3 -> eq_dec p2 p3
-       | _ -> false)
-    | XH ->
-      (match y0 with
-       | XH -> true
-       | _ -> false)
-  
-  (** val peano_rect : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 **)
-  
-  let rec peano_rect a f p =
-    let f2 = peano_rect (f XH a) (fun p2 x -> f (succ (XO p2)) (f (XO p2) x))
-    in
-    (match p with
-     | XI q0 -> f (XO q0) (f2 q0)
-     | XO q0 -> f2 q0
-     | XH -> a)
-  
-  (** val peano_rec : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 **)
-  
-  let peano_rec =
-    peano_rect
-  
-  type coq_PeanoView =
-  | PeanoOne
-  | PeanoSucc of positive * coq_PeanoView
-  
-  (** val coq_PeanoView_rect :
-      'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive ->
-      coq_PeanoView -> 'a1 **)
-  
-  let rec coq_PeanoView_rect f f0 p = function
-  | PeanoOne -> f
-  | PeanoSucc (p3, p4) -> f0 p3 p4 (coq_PeanoView_rect f f0 p3 p4)
-  
-  (** val coq_PeanoView_rec :
-      'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive ->
-      coq_PeanoView -> 'a1 **)
-  
-  let rec coq_PeanoView_rec f f0 p = function
-  | PeanoOne -> f
-  | PeanoSucc (p3, p4) -> f0 p3 p4 (coq_PeanoView_rec f f0 p3 p4)
-  
-  (** val peanoView_xO : positive -> coq_PeanoView -> coq_PeanoView **)
-  
-  let rec peanoView_xO p = function
-  | PeanoOne -> PeanoSucc (XH, PeanoOne)
-  | PeanoSucc (p2, q1) ->
-    PeanoSucc ((succ (XO p2)), (PeanoSucc ((XO p2), (peanoView_xO p2 q1))))
-  
-  (** val peanoView_xI : positive -> coq_PeanoView -> coq_PeanoView **)
-  
-  let rec peanoView_xI p = function
-  | PeanoOne -> PeanoSucc ((succ XH), (PeanoSucc (XH, PeanoOne)))
-  | PeanoSucc (p2, q1) ->
-    PeanoSucc ((succ (XI p2)), (PeanoSucc ((XI p2), (peanoView_xI p2 q1))))
-  
-  (** val peanoView : positive -> coq_PeanoView **)
-  
-  let rec peanoView = function
-  | XI p2 -> peanoView_xI p2 (peanoView p2)
-  | XO p2 -> peanoView_xO p2 (peanoView p2)
-  | XH -> PeanoOne
-  
-  (** val coq_PeanoView_iter :
-      'a1 -> (positive -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1 **)
-  
-  let rec coq_PeanoView_iter a f p = function
-  | PeanoOne -> a
-  | PeanoSucc (p2, q1) -> f p2 (coq_PeanoView_iter a f p2 q1)
-  
-  (** val switch_Eq : comparison -> comparison -> comparison **)
-  
-  let switch_Eq c = function
-  | Eq -> c
-  | x -> x
-  
-  (** val mask2cmp : mask -> comparison **)
-  
-  let mask2cmp = function
-  | IsNul -> Eq
-  | IsPos p2 -> Gt
-  | IsNeg -> Lt
-  
-  module T = 
-   struct 
-    
-   end
-  
-  module ORev = 
-   struct 
-    type t = Coq__1.t
-   end
-  
-  module MRev = 
-   struct 
-    (** val max : t -> t -> t **)
-    
-    let max x y =
-      min y x
-   end
-  
-  module MPRev = MaxLogicalProperties(ORev)(MRev)
-  
-  module P = 
-   struct 
-    (** val max_case_strong :
-        t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1)
-        -> 'a1 **)
-    
-    let max_case_strong n0 m compat hl hr =
-      let c = compSpec2Type n0 m (compare n0 m) in
-      (match c with
-       | CompGtT -> compat n0 (max n0 m) __ (hl __)
-       | _ -> compat m (max n0 m) __ (hr __))
-    
-    (** val max_case :
-        t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **)
-    
-    let max_case n0 m x x0 x1 =
-      max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1)
-    
-    (** val max_dec : t -> t -> bool **)
-    
-    let max_dec n0 m =
-      max_case n0 m (fun x y _ h0 -> h0) true false
-    
-    (** val min_case_strong :
-        t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1)
-        -> 'a1 **)
-    
-    let min_case_strong n0 m compat hl hr =
-      let c = compSpec2Type n0 m (compare n0 m) in
-      (match c with
-       | CompGtT -> compat m (min n0 m) __ (hr __)
-       | _ -> compat n0 (min n0 m) __ (hl __))
-    
-    (** val min_case :
-        t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **)
-    
-    let min_case n0 m x x0 x1 =
-      min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1)
-    
-    (** val min_dec : t -> t -> bool **)
-    
-    let min_dec n0 m =
-      min_case n0 m (fun x y _ h0 -> h0) true false
-   end
-  
-  (** val max_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
-  
-  let max_case_strong n0 m x x0 =
-    P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0
-  
-  (** val max_case : t -> t -> 'a1 -> 'a1 -> 'a1 **)
-  
-  let max_case n0 m x x0 =
-    max_case_strong n0 m (fun _ -> x) (fun _ -> x0)
-  
-  (** val max_dec : t -> t -> bool **)
-  
-  let max_dec =
-    P.max_dec
-  
-  (** val min_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
-  
-  let min_case_strong n0 m x x0 =
-    P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0
-  
-  (** val min_case : t -> t -> 'a1 -> 'a1 -> 'a1 **)
-  
-  let min_case n0 m x x0 =
-    min_case_strong n0 m (fun _ -> x) (fun _ -> x0)
-  
-  (** val min_dec : t -> t -> bool **)
-  
-  let min_dec =
-    P.min_dec
  end
 
-module N = 
- struct 
-  type t = n
-  
-  (** val zero : n **)
-  
-  let zero =
-    N0
-  
-  (** val one : n **)
-  
-  let one =
-    Npos XH
-  
-  (** val two : n **)
-  
-  let two =
-    Npos (XO XH)
-  
-  (** val succ_double : n -> n **)
-  
-  let succ_double = function
-  | N0 -> Npos XH
-  | Npos p -> Npos (XI p)
-  
-  (** val double : n -> n **)
-  
-  let double = function
-  | N0 -> N0
-  | Npos p -> Npos (XO p)
-  
-  (** val succ : n -> n **)
-  
-  let succ = function
-  | N0 -> Npos XH
-  | Npos p -> Npos (Coq_Pos.succ p)
-  
-  (** val pred : n -> n **)
-  
-  let pred = function
-  | N0 -> N0
-  | Npos p -> Coq_Pos.pred_N p
-  
-  (** val succ_pos : n -> positive **)
-  
-  let succ_pos = function
-  | N0 -> XH
-  | Npos p -> Coq_Pos.succ p
-  
-  (** val add : n -> n -> n **)
-  
-  let add n0 m =
-    match n0 with
-    | N0 -> m
-    | Npos p ->
-      (match m with
-       | N0 -> n0
-       | Npos q0 -> Npos (Coq_Pos.add p q0))
-  
-  (** val sub : n -> n -> n **)
-  
-  let sub n0 m =
-    match n0 with
-    | N0 -> N0
-    | Npos n' ->
-      (match m with
-       | N0 -> n0
-       | Npos m' ->
-         (match Coq_Pos.sub_mask n' m' with
-          | Coq_Pos.IsPos p -> Npos p
-          | _ -> N0))
-  
-  (** val mul : n -> n -> n **)
-  
-  let mul n0 m =
-    match n0 with
-    | N0 -> N0
-    | Npos p ->
-      (match m with
-       | N0 -> N0
-       | Npos q0 -> Npos (Coq_Pos.mul p q0))
-  
-  (** val compare : n -> n -> comparison **)
-  
-  let compare n0 m =
-    match n0 with
-    | N0 ->
-      (match m with
-       | N0 -> Eq
-       | Npos m' -> Lt)
-    | Npos n' ->
-      (match m with
-       | N0 -> Gt
-       | Npos m' -> Coq_Pos.compare n' m')
-  
-  (** val eqb : n -> n -> bool **)
-  
-  let eqb n0 m =
-    match n0 with
-    | N0 ->
-      (match m with
-       | N0 -> true
-       | Npos p -> false)
-    | Npos p ->
-      (match m with
-       | N0 -> false
-       | Npos q0 -> Coq_Pos.eqb p q0)
-  
-  (** val leb : n -> n -> bool **)
-  
-  let leb x y =
-    match compare x y with
-    | Gt -> false
-    | _ -> true
-  
-  (** val ltb : n -> n -> bool **)
-  
-  let ltb x y =
-    match compare x y with
-    | Lt -> true
-    | _ -> false
-  
-  (** val min : n -> n -> n **)
-  
-  let min n0 n' =
-    match compare n0 n' with
-    | Gt -> n'
-    | _ -> n0
-  
-  (** val max : n -> n -> n **)
-  
-  let max n0 n' =
-    match compare n0 n' with
-    | Gt -> n0
-    | _ -> n'
-  
-  (** val div2 : n -> n **)
-  
-  let div2 = function
-  | N0 -> N0
-  | Npos p2 ->
-    (match p2 with
-     | XI p -> Npos p
-     | XO p -> Npos p
-     | XH -> N0)
-  
-  (** val even : n -> bool **)
-  
-  let even = function
-  | N0 -> true
-  | Npos p ->
-    (match p with
-     | XO p2 -> true
-     | _ -> false)
-  
-  (** val odd : n -> bool **)
-  
-  let odd n0 =
-    negb (even n0)
-  
-  (** val pow : n -> n -> n **)
-  
-  let pow n0 = function
-  | N0 -> Npos XH
-  | Npos p2 ->
-    (match n0 with
-     | N0 -> N0
-     | Npos q0 -> Npos (Coq_Pos.pow q0 p2))
-  
-  (** val log2 : n -> n **)
-  
-  let log2 = function
-  | N0 -> N0
-  | Npos p2 ->
-    (match p2 with
-     | XI p -> Npos (Coq_Pos.size p)
-     | XO p -> Npos (Coq_Pos.size p)
-     | XH -> N0)
-  
-  (** val size : n -> n **)
-  
-  let size = function
-  | N0 -> N0
-  | Npos p -> Npos (Coq_Pos.size p)
-  
-  (** val size_nat : n -> nat **)
-  
-  let size_nat = function
-  | N0 -> O
-  | Npos p -> Coq_Pos.size_nat p
-  
-  (** val pos_div_eucl : positive -> n -> n * n **)
-  
-  let rec pos_div_eucl a b =
-    match a with
-    | XI a' ->
-      let q0,r = pos_div_eucl a' b in
-      let r' = succ_double r in
-      if leb b r' then (succ_double q0),(sub r' b) else (double q0),r'
-    | XO a' ->
-      let q0,r = pos_div_eucl a' b in
-      let r' = double r in
-      if leb b r' then (succ_double q0),(sub r' b) else (double q0),r'
-    | XH ->
-      (match b with
-       | N0 -> N0,(Npos XH)
-       | Npos p ->
-         (match p with
-          | XH -> (Npos XH),N0
-          | _ -> N0,(Npos XH)))
-  
-  (** val div_eucl : n -> n -> n * n **)
-  
-  let div_eucl a b =
-    match a with
-    | N0 -> N0,N0
-    | Npos na ->
-      (match b with
-       | N0 -> N0,a
-       | Npos p -> pos_div_eucl na b)
-  
-  (** val div : n -> n -> n **)
-  
-  let div a b =
-    fst (div_eucl a b)
-  
-  (** val modulo : n -> n -> n **)
-  
-  let modulo a b =
-    snd (div_eucl a b)
-  
-  (** val gcd : n -> n -> n **)
-  
-  let gcd a b =
-    match a with
-    | N0 -> b
-    | Npos p ->
-      (match b with
-       | N0 -> a
-       | Npos q0 -> Npos (Coq_Pos.gcd p q0))
-  
-  (** val ggcd : n -> n -> n * (n * n) **)
-  
-  let ggcd a b =
-    match a with
-    | N0 -> b,(N0,(Npos XH))
-    | Npos p ->
-      (match b with
-       | N0 -> a,((Npos XH),N0)
-       | Npos q0 ->
-         let g,p2 = Coq_Pos.ggcd p q0 in
-         let aa,bb = p2 in (Npos g),((Npos aa),(Npos bb)))
-  
-  (** val sqrtrem : n -> n * n **)
-  
-  let sqrtrem = function
-  | N0 -> N0,N0
-  | Npos p ->
-    let s,m = Coq_Pos.sqrtrem p in
-    (match m with
-     | Coq_Pos.IsPos r -> (Npos s),(Npos r)
-     | _ -> (Npos s),N0)
-  
-  (** val sqrt : n -> n **)
-  
-  let sqrt = function
-  | N0 -> N0
-  | Npos p -> Npos (Coq_Pos.sqrt p)
-  
-  (** val coq_lor : n -> n -> n **)
-  
-  let coq_lor n0 m =
-    match n0 with
-    | N0 -> m
-    | Npos p ->
-      (match m with
-       | N0 -> n0
-       | Npos q0 -> Npos (Coq_Pos.coq_lor p q0))
-  
-  (** val coq_land : n -> n -> n **)
-  
-  let coq_land n0 m =
-    match n0 with
-    | N0 -> N0
-    | Npos p ->
-      (match m with
-       | N0 -> N0
-       | Npos q0 -> Coq_Pos.coq_land p q0)
-  
-  (** val ldiff : n -> n -> n **)
-  
-  let ldiff n0 m =
-    match n0 with
-    | N0 -> N0
-    | Npos p ->
-      (match m with
-       | N0 -> n0
-       | Npos q0 -> Coq_Pos.ldiff p q0)
-  
-  (** val coq_lxor : n -> n -> n **)
-  
-  let coq_lxor n0 m =
-    match n0 with
-    | N0 -> m
-    | Npos p ->
-      (match m with
-       | N0 -> n0
-       | Npos q0 -> Coq_Pos.coq_lxor p q0)
-  
-  (** val shiftl_nat : n -> nat -> n **)
-  
-  let shiftl_nat a n0 =
-    nat_iter n0 double a
-  
-  (** val shiftr_nat : n -> nat -> n **)
-  
-  let shiftr_nat a n0 =
-    nat_iter n0 div2 a
-  
-  (** val shiftl : n -> n -> n **)
-  
-  let shiftl a n0 =
-    match a with
-    | N0 -> N0
-    | Npos a0 -> Npos (Coq_Pos.shiftl a0 n0)
-  
-  (** val shiftr : n -> n -> n **)
-  
-  let shiftr a = function
-  | N0 -> a
-  | Npos p -> Coq_Pos.iter p div2 a
-  
-  (** val testbit_nat : n -> nat -> bool **)
-  
-  let testbit_nat = function
-  | N0 -> (fun x -> false)
-  | Npos p -> Coq_Pos.testbit_nat p
-  
-  (** val testbit : n -> n -> bool **)
-  
-  let testbit a n0 =
-    match a with
-    | N0 -> false
-    | Npos p -> Coq_Pos.testbit p n0
-  
-  (** val to_nat : n -> nat **)
-  
-  let to_nat = function
-  | N0 -> O
-  | Npos p -> Coq_Pos.to_nat p
-  
+module N =
+ struct
   (** val of_nat : nat -> n **)
-  
+
   let of_nat = function
   | O -> N0
   | S n' -> Npos (Coq_Pos.of_succ_nat n')
-  
-  (** val iter : n -> ('a1 -> 'a1) -> 'a1 -> 'a1 **)
-  
-  let iter n0 f x =
-    match n0 with
-    | N0 -> x
-    | Npos p -> Coq_Pos.iter p f x
-  
-  (** val eq_dec : n -> n -> bool **)
-  
-  let eq_dec n0 m =
-    match n0 with
-    | N0 ->
-      (match m with
-       | N0 -> true
-       | Npos p -> false)
-    | Npos x ->
-      (match m with
-       | N0 -> false
-       | Npos p2 -> Coq_Pos.eq_dec x p2)
-  
-  (** val discr : n -> positive option **)
-  
-  let discr = function
-  | N0 -> None
-  | Npos p -> Some p
-  
-  (** val binary_rect :
-      'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 **)
-  
-  let binary_rect f0 f2 fS2 n0 =
-    let f2' = fun p -> f2 (Npos p) in
-    let fS2' = fun p -> fS2 (Npos p) in
-    (match n0 with
-     | N0 -> f0
-     | Npos p ->
-       let rec f = function
-       | XI p3 -> fS2' p3 (f p3)
-       | XO p3 -> f2' p3 (f p3)
-       | XH -> fS2 N0 f0
-       in f p)
-  
-  (** val binary_rec :
-      'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 **)
-  
-  let binary_rec =
-    binary_rect
-  
-  (** val peano_rect : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **)
-  
-  let peano_rect f0 f n0 =
-    let f' = fun p -> f (Npos p) in
-    (match n0 with
-     | N0 -> f0
-     | Npos p -> Coq_Pos.peano_rect (f N0 f0) f' p)
-  
-  (** val peano_rec : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **)
-  
-  let peano_rec =
-    peano_rect
-  
-  module BootStrap = 
-   struct 
-    
-   end
-  
-  (** val recursion : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **)
-  
-  let recursion x =
-    peano_rect x
-  
-  module OrderElts = 
-   struct 
-    type t = n
-   end
-  
-  module OrderTac = MakeOrderTac(OrderElts)
-  
-  module NZPowP = 
-   struct 
-    
-   end
-  
-  module NZSqrtP = 
-   struct 
-    
-   end
-  
-  (** val sqrt_up : n -> n **)
-  
-  let sqrt_up a =
-    match compare N0 a with
-    | Lt -> succ (sqrt (pred a))
-    | _ -> N0
-  
-  (** val log2_up : n -> n **)
-  
-  let log2_up a =
-    match compare (Npos XH) a with
-    | Lt -> succ (log2 (pred a))
-    | _ -> N0
-  
-  module NZDivP = 
-   struct 
-    
-   end
-  
-  (** val lcm : n -> n -> n **)
-  
-  let lcm a b =
-    mul a (div b (gcd a b))
-  
-  (** val b2n : bool -> n **)
-  
-  let b2n = function
-  | true -> Npos XH
-  | false -> N0
-  
-  (** val setbit : n -> n -> n **)
-  
-  let setbit a n0 =
-    coq_lor a (shiftl (Npos XH) n0)
-  
-  (** val clearbit : n -> n -> n **)
-  
-  let clearbit a n0 =
-    ldiff a (shiftl (Npos XH) n0)
-  
-  (** val ones : n -> n **)
-  
-  let ones n0 =
-    pred (shiftl (Npos XH) n0)
-  
-  (** val lnot : n -> n -> n **)
-  
-  let lnot a n0 =
-    coq_lxor a (ones n0)
-  
-  module T = 
-   struct 
-    
-   end
-  
-  module ORev = 
-   struct 
-    type t = n
-   end
-  
-  module MRev = 
-   struct 
-    (** val max : n -> n -> n **)
-    
-    let max x y =
-      min y x
-   end
-  
-  module MPRev = MaxLogicalProperties(ORev)(MRev)
-  
-  module P = 
-   struct 
-    (** val max_case_strong :
-        n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1)
-        -> 'a1 **)
-    
-    let max_case_strong n0 m compat hl hr =
-      let c = compSpec2Type n0 m (compare n0 m) in
-      (match c with
-       | CompGtT -> compat n0 (max n0 m) __ (hl __)
-       | _ -> compat m (max n0 m) __ (hr __))
-    
-    (** val max_case :
-        n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **)
-    
-    let max_case n0 m x x0 x1 =
-      max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1)
-    
-    (** val max_dec : n -> n -> bool **)
-    
-    let max_dec n0 m =
-      max_case n0 m (fun x y _ h0 -> h0) true false
-    
-    (** val min_case_strong :
-        n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1)
-        -> 'a1 **)
-    
-    let min_case_strong n0 m compat hl hr =
-      let c = compSpec2Type n0 m (compare n0 m) in
-      (match c with
-       | CompGtT -> compat m (min n0 m) __ (hr __)
-       | _ -> compat n0 (min n0 m) __ (hl __))
-    
-    (** val min_case :
-        n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **)
-    
-    let min_case n0 m x x0 x1 =
-      min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1)
-    
-    (** val min_dec : n -> n -> bool **)
-    
-    let min_dec n0 m =
-      min_case n0 m (fun x y _ h0 -> h0) true false
-   end
-  
-  (** val max_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
-  
-  let max_case_strong n0 m x x0 =
-    P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0
-  
-  (** val max_case : n -> n -> 'a1 -> 'a1 -> 'a1 **)
-  
-  let max_case n0 m x x0 =
-    max_case_strong n0 m (fun _ -> x) (fun _ -> x0)
-  
-  (** val max_dec : n -> n -> bool **)
-  
-  let max_dec =
-    P.max_dec
-  
-  (** val min_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
-  
-  let min_case_strong n0 m x x0 =
-    P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0
-  
-  (** val min_case : n -> n -> 'a1 -> 'a1 -> 'a1 **)
-  
-  let min_case n0 m x x0 =
-    min_case_strong n0 m (fun _ -> x) (fun _ -> x0)
-  
-  (** val min_dec : n -> n -> bool **)
-  
-  let min_dec =
-    P.min_dec
  end
 
 (** val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 **)
@@ -2006,66 +280,49 @@ let rec nth n0 l default =
   | O ->
     (match l with
      | [] -> default
-     | x::l' -> x)
+     | x::_ -> x)
   | S m ->
     (match l with
      | [] -> default
-     | x::t1 -> nth m t1 default)
+     | _::t0 -> nth m t0 default)
 
 (** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **)
 
 let rec map f = function
 | [] -> []
-| a::t1 -> (f a)::(map f t1)
+| a::t0 -> (f a)::(map f t0)
 
 (** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **)
 
 let rec fold_right f a0 = function
 | [] -> a0
-| b::t1 -> f b (fold_right f a0 t1)
-
-module Z = 
- struct 
-  type t = z
-  
-  (** val zero : z **)
-  
-  let zero =
-    Z0
-  
-  (** val one : z **)
-  
-  let one =
-    Zpos XH
-  
-  (** val two : z **)
-  
-  let two =
-    Zpos (XO XH)
-  
+| b::t0 -> f b (fold_right f a0 t0)
+
+module Z =
+ struct
   (** val double : z -> z **)
-  
+
   let double = function
   | Z0 -> Z0
   | Zpos p -> Zpos (XO p)
   | Zneg p -> Zneg (XO p)
-  
+
   (** val succ_double : z -> z **)
-  
+
   let succ_double = function
   | Z0 -> Zpos XH
   | Zpos p -> Zpos (XI p)
   | Zneg p -> Zneg (Coq_Pos.pred_double p)
-  
+
   (** val pred_double : z -> z **)
-  
+
   let pred_double = function
   | Z0 -> Zneg XH
   | Zpos p -> Zpos (Coq_Pos.pred_double p)
   | Zneg p -> Zneg (XI p)
-  
+
   (** val pos_sub : positive -> positive -> z **)
-  
+
   let rec pos_sub x y =
     match x with
     | XI p ->
@@ -2083,9 +340,9 @@ module Z =
        | XI q0 -> Zneg (XO q0)
        | XO q0 -> Zneg (Coq_Pos.pred_double q0)
        | XH -> Z0)
-  
+
   (** val add : z -> z -> z **)
-  
+
   let add x y =
     match x with
     | Z0 -> y
@@ -2099,31 +356,21 @@ module Z =
        | Z0 -> x
        | Zpos y' -> pos_sub y' x'
        | Zneg y' -> Zneg (Coq_Pos.add x' y'))
-  
+
   (** val opp : z -> z **)
-  
+
   let opp = function
   | Z0 -> Z0
   | Zpos x0 -> Zneg x0
   | Zneg x0 -> Zpos x0
-  
-  (** val succ : z -> z **)
-  
-  let succ x =
-    add x (Zpos XH)
-  
-  (** val pred : z -> z **)
-  
-  let pred x =
-    add x (Zneg XH)
-  
+
   (** val sub : z -> z -> z **)
-  
+
   let sub m n0 =
     add m (opp n0)
-  
+
   (** val mul : z -> z -> z **)
-  
+
   let mul x y =
     match x with
     | Z0 -> Z0
@@ -2137,28 +384,16 @@ module Z =
        | Z0 -> Z0
        | Zpos y' -> Zneg (Coq_Pos.mul x' y')
        | Zneg y' -> Zpos (Coq_Pos.mul x' y'))
-  
-  (** val pow_pos : z -> positive -> z **)
-  
-  let pow_pos z0 n0 =
-    Coq_Pos.iter n0 (mul z0) (Zpos XH)
-  
-  (** val pow : z -> z -> z **)
-  
-  let pow x = function
-  | Z0 -> Zpos XH
-  | Zpos p -> pow_pos x p
-  | Zneg p -> Z0
-  
+
   (** val compare : z -> z -> comparison **)
-  
+
   let compare x y =
     match x with
     | Z0 ->
       (match y with
        | Z0 -> Eq
-       | Zpos y' -> Lt
-       | Zneg y' -> Gt)
+       | Zpos _ -> Lt
+       | Zneg _ -> Gt)
     | Zpos x' ->
       (match y with
        | Zpos y' -> Coq_Pos.compare x' y'
@@ -2167,151 +402,74 @@ module Z =
       (match y with
        | Zneg y' -> compOpp (Coq_Pos.compare x' y')
        | _ -> Lt)
-  
-  (** val sgn : z -> z **)
-  
-  let sgn = function
-  | Z0 -> Z0
-  | Zpos p -> Zpos XH
-  | Zneg p -> Zneg XH
-  
+
   (** val leb : z -> z -> bool **)
-  
+
   let leb x y =
     match compare x y with
     | Gt -> false
     | _ -> true
-  
-  (** val geb : z -> z -> bool **)
-  
-  let geb x y =
-    match compare x y with
-    | Lt -> false
-    | _ -> true
-  
+
   (** val ltb : z -> z -> bool **)
-  
+
   let ltb x y =
     match compare x y with
     | Lt -> true
     | _ -> false
-  
+
   (** val gtb : z -> z -> bool **)
-  
+
   let gtb x y =
     match compare x y with
     | Gt -> true
     | _ -> false
-  
-  (** val eqb : z -> z -> bool **)
-  
-  let eqb x y =
-    match x with
-    | Z0 ->
-      (match y with
-       | Z0 -> true
-       | _ -> false)
-    | Zpos p ->
-      (match y with
-       | Zpos q0 -> Coq_Pos.eqb p q0
-       | _ -> false)
-    | Zneg p ->
-      (match y with
-       | Zneg q0 -> Coq_Pos.eqb p q0
-       | _ -> false)
-  
+
   (** val max : z -> z -> z **)
-  
+
   let max n0 m =
     match compare n0 m with
     | Lt -> m
     | _ -> n0
-  
-  (** val min : z -> z -> z **)
-  
-  let min n0 m =
-    match compare n0 m with
-    | Gt -> m
-    | _ -> n0
-  
+
   (** val abs : z -> z **)
-  
+
   let abs = function
   | Zneg p -> Zpos p
   | x -> x
-  
-  (** val abs_nat : z -> nat **)
-  
-  let abs_nat = function
-  | Z0 -> O
-  | Zpos p -> Coq_Pos.to_nat p
-  | Zneg p -> Coq_Pos.to_nat p
-  
-  (** val abs_N : z -> n **)
-  
-  let abs_N = function
-  | Z0 -> N0
-  | Zpos p -> Npos p
-  | Zneg p -> Npos p
-  
-  (** val to_nat : z -> nat **)
-  
-  let to_nat = function
-  | Zpos p -> Coq_Pos.to_nat p
-  | _ -> O
-  
+
   (** val to_N : z -> n **)
-  
+
   let to_N = function
   | Zpos p -> Npos p
   | _ -> N0
-  
-  (** val of_nat : nat -> z **)
-  
-  let of_nat = function
-  | O -> Z0
-  | S n1 -> Zpos (Coq_Pos.of_succ_nat n1)
-  
-  (** val of_N : n -> z **)
-  
-  let of_N = function
-  | N0 -> Z0
-  | Npos p -> Zpos p
-  
-  (** val iter : z -> ('a1 -> 'a1) -> 'a1 -> 'a1 **)
-  
-  let iter n0 f x =
-    match n0 with
-    | Zpos p -> Coq_Pos.iter p f x
-    | _ -> x
-  
+
   (** val pos_div_eucl : positive -> z -> z * z **)
-  
+
   let rec pos_div_eucl a b =
     match a with
     | XI a' ->
       let q0,r = pos_div_eucl a' b in
       let r' = add (mul (Zpos (XO XH)) r) (Zpos XH) in
-      if gtb b r'
+      if ltb r' b
       then (mul (Zpos (XO XH)) q0),r'
       else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b)
     | XO a' ->
       let q0,r = pos_div_eucl a' b in
       let r' = mul (Zpos (XO XH)) r in
-      if gtb b r'
+      if ltb r' b
       then (mul (Zpos (XO XH)) q0),r'
       else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b)
-    | XH -> if geb b (Zpos (XO XH)) then Z0,(Zpos XH) else (Zpos XH),Z0
-  
+    | XH -> if leb (Zpos (XO XH)) b then Z0,(Zpos XH) else (Zpos XH),Z0
+
   (** val div_eucl : z -> z -> z * z **)
-  
+
   let div_eucl a b =
     match a with
     | Z0 -> Z0,Z0
     | Zpos a' ->
       (match b with
        | Z0 -> Z0,Z0
-       | Zpos p -> pos_div_eucl a' b
+       | Zpos _ -> pos_div_eucl a' b
        | Zneg b' ->
          let q0,r = pos_div_eucl a' (Zpos b') in
          (match r with
@@ -2320,131 +478,20 @@ module Z =
     | Zneg a' ->
       (match b with
        | Z0 -> Z0,Z0
-       | Zpos p ->
+       | Zpos _ ->
          let q0,r = pos_div_eucl a' b in
          (match r with
           | Z0 -> (opp q0),Z0
           | _ -> (opp (add q0 (Zpos XH))),(sub b r))
        | Zneg b' -> let q0,r = pos_div_eucl a' (Zpos b') in q0,(opp r))
-  
+
   (** val div : z -> z -> z **)
-  
+
   let div a b =
-    let q0,x = div_eucl a b in q0
-  
-  (** val modulo : z -> z -> z **)
-  
-  let modulo a b =
-    let x,r = div_eucl a b in r
-  
-  (** val quotrem : z -> z -> z * z **)
-  
-  let quotrem a b =
-    match a with
-    | Z0 -> Z0,Z0
-    | Zpos a0 ->
-      (match b with
-       | Z0 -> Z0,a
-       | Zpos b0 ->
-         let q0,r = N.pos_div_eucl a0 (Npos b0) in (of_N q0),(of_N r)
-       | Zneg b0 ->
-         let q0,r = N.pos_div_eucl a0 (Npos b0) in (opp (of_N q0)),(of_N r))
-    | Zneg a0 ->
-      (match b with
-       | Z0 -> Z0,a
-       | Zpos b0 ->
-         let q0,r = N.pos_div_eucl a0 (Npos b0) in
-         (opp (of_N q0)),(opp (of_N r))
-       | Zneg b0 ->
-         let q0,r = N.pos_div_eucl a0 (Npos b0) in (of_N q0),(opp (of_N r)))
-  
-  (** val quot : z -> z -> z **)
-  
-  let quot a b =
-    fst (quotrem a b)
-  
-  (** val rem : z -> z -> z **)
-  
-  let rem a b =
-    snd (quotrem a b)
-  
-  (** val even : z -> bool **)
-  
-  let even = function
-  | Z0 -> true
-  | Zpos p ->
-    (match p with
-     | XO p2 -> true
-     | _ -> false)
-  | Zneg p ->
-    (match p with
-     | XO p2 -> true
-     | _ -> false)
-  
-  (** val odd : z -> bool **)
-  
-  let odd = function
-  | Z0 -> false
-  | Zpos p ->
-    (match p with
-     | XO p2 -> false
-     | _ -> true)
-  | Zneg p ->
-    (match p with
-     | XO p2 -> false
-     | _ -> true)
-  
-  (** val div2 : z -> z **)
-  
-  let div2 = function
-  | Z0 -> Z0
-  | Zpos p ->
-    (match p with
-     | XH -> Z0
-     | _ -> Zpos (Coq_Pos.div2 p))
-  | Zneg p -> Zneg (Coq_Pos.div2_up p)
-  
-  (** val quot2 : z -> z **)
-  
-  let quot2 = function
-  | Z0 -> Z0
-  | Zpos p ->
-    (match p with
-     | XH -> Z0
-     | _ -> Zpos (Coq_Pos.div2 p))
-  | Zneg p ->
-    (match p with
-     | XH -> Z0
-     | _ -> Zneg (Coq_Pos.div2 p))
-  
-  (** val log2 : z -> z **)
-  
-  let log2 = function
-  | Zpos p2 ->
-    (match p2 with
-     | XI p -> Zpos (Coq_Pos.size p)
-     | XO p -> Zpos (Coq_Pos.size p)
-     | XH -> Z0)
-  | _ -> Z0
-  
-  (** val sqrtrem : z -> z * z **)
-  
-  let sqrtrem = function
-  | Zpos p ->
-    let s,m = Coq_Pos.sqrtrem p in
-    (match m with
-     | Coq_Pos.IsPos r -> (Zpos s),(Zpos r)
-     | _ -> (Zpos s),Z0)
-  | _ -> Z0,Z0
-  
-  (** val sqrt : z -> z **)
-  
-  let sqrt = function
-  | Zpos p -> Zpos (Coq_Pos.sqrt p)
-  | _ -> Z0
-  
+    let q0,_ = div_eucl a b in q0
+
   (** val gcd : z -> z -> z **)
-  
+
   let gcd a b =
     match a with
     | Z0 -> abs b
@@ -2458,316 +505,6 @@ module Z =
        | Z0 -> abs a
        | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0)
        | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0))
-  
-  (** val ggcd : z -> z -> z * (z * z) **)
-  
-  let ggcd a b =
-    match a with
-    | Z0 -> (abs b),(Z0,(sgn b))
-    | Zpos a0 ->
-      (match b with
-       | Z0 -> (abs a),((sgn a),Z0)
-       | Zpos b0 ->
-         let g,p = Coq_Pos.ggcd a0 b0 in
-         let aa,bb = p in (Zpos g),((Zpos aa),(Zpos bb))
-       | Zneg b0 ->
-         let g,p = Coq_Pos.ggcd a0 b0 in
-         let aa,bb = p in (Zpos g),((Zpos aa),(Zneg bb)))
-    | Zneg a0 ->
-      (match b with
-       | Z0 -> (abs a),((sgn a),Z0)
-       | Zpos b0 ->
-         let g,p = Coq_Pos.ggcd a0 b0 in
-         let aa,bb = p in (Zpos g),((Zneg aa),(Zpos bb))
-       | Zneg b0 ->
-         let g,p = Coq_Pos.ggcd a0 b0 in
-         let aa,bb = p in (Zpos g),((Zneg aa),(Zneg bb)))
-  
-  (** val testbit : z -> z -> bool **)
-  
-  let testbit a = function
-  | Z0 -> odd a
-  | Zpos p ->
-    (match a with
-     | Z0 -> false
-     | Zpos a0 -> Coq_Pos.testbit a0 (Npos p)
-     | Zneg a0 -> negb (N.testbit (Coq_Pos.pred_N a0) (Npos p)))
-  | Zneg p -> false
-  
-  (** val shiftl : z -> z -> z **)
-  
-  let shiftl a = function
-  | Z0 -> a
-  | Zpos p -> Coq_Pos.iter p (mul (Zpos (XO XH))) a
-  | Zneg p -> Coq_Pos.iter p div2 a
-  
-  (** val shiftr : z -> z -> z **)
-  
-  let shiftr a n0 =
-    shiftl a (opp n0)
-  
-  (** val coq_lor : z -> z -> z **)
-  
-  let coq_lor a b =
-    match a with
-    | Z0 -> b
-    | Zpos a0 ->
-      (match b with
-       | Z0 -> a
-       | Zpos b0 -> Zpos (Coq_Pos.coq_lor a0 b0)
-       | Zneg b0 -> Zneg (N.succ_pos (N.ldiff (Coq_Pos.pred_N b0) (Npos a0))))
-    | Zneg a0 ->
-      (match b with
-       | Z0 -> a
-       | Zpos b0 -> Zneg (N.succ_pos (N.ldiff (Coq_Pos.pred_N a0) (Npos b0)))
-       | Zneg b0 ->
-         Zneg
-           (N.succ_pos (N.coq_land (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0))))
-  
-  (** val coq_land : z -> z -> z **)
-  
-  let coq_land a b =
-    match a with
-    | Z0 -> Z0
-    | Zpos a0 ->
-      (match b with
-       | Z0 -> Z0
-       | Zpos b0 -> of_N (Coq_Pos.coq_land a0 b0)
-       | Zneg b0 -> of_N (N.ldiff (Npos a0) (Coq_Pos.pred_N b0)))
-    | Zneg a0 ->
-      (match b with
-       | Z0 -> Z0
-       | Zpos b0 -> of_N (N.ldiff (Npos b0) (Coq_Pos.pred_N a0))
-       | Zneg b0 ->
-         Zneg
-           (N.succ_pos (N.coq_lor (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0))))
-  
-  (** val ldiff : z -> z -> z **)
-  
-  let ldiff a b =
-    match a with
-    | Z0 -> Z0
-    | Zpos a0 ->
-      (match b with
-       | Z0 -> a
-       | Zpos b0 -> of_N (Coq_Pos.ldiff a0 b0)
-       | Zneg b0 -> of_N (N.coq_land (Npos a0) (Coq_Pos.pred_N b0)))
-    | Zneg a0 ->
-      (match b with
-       | Z0 -> a
-       | Zpos b0 ->
-         Zneg (N.succ_pos (N.coq_lor (Coq_Pos.pred_N a0) (Npos b0)))
-       | Zneg b0 -> of_N (N.ldiff (Coq_Pos.pred_N b0) (Coq_Pos.pred_N a0)))
-  
-  (** val coq_lxor : z -> z -> z **)
-  
-  let coq_lxor a b =
-    match a with
-    | Z0 -> b
-    | Zpos a0 ->
-      (match b with
-       | Z0 -> a
-       | Zpos b0 -> of_N (Coq_Pos.coq_lxor a0 b0)
-       | Zneg b0 ->
-         Zneg (N.succ_pos (N.coq_lxor (Npos a0) (Coq_Pos.pred_N b0))))
-    | Zneg a0 ->
-      (match b with
-       | Z0 -> a
-       | Zpos b0 ->
-         Zneg (N.succ_pos (N.coq_lxor (Coq_Pos.pred_N a0) (Npos b0)))
-       | Zneg b0 -> of_N (N.coq_lxor (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0)))
-  
-  (** val eq_dec : z -> z -> bool **)
-  
-  let eq_dec x y =
-    match x with
-    | Z0 ->
-      (match y with
-       | Z0 -> true
-       | _ -> false)
-    | Zpos x0 ->
-      (match y with
-       | Zpos p2 -> Coq_Pos.eq_dec x0 p2
-       | _ -> false)
-    | Zneg x0 ->
-      (match y with
-       | Zneg p2 -> Coq_Pos.eq_dec x0 p2
-       | _ -> false)
-  
-  module BootStrap = 
-   struct 
-    
-   end
-  
-  module OrderElts = 
-   struct 
-    type t = z
-   end
-  
-  module OrderTac = MakeOrderTac(OrderElts)
-  
-  (** val sqrt_up : z -> z **)
-  
-  let sqrt_up a =
-    match compare Z0 a with
-    | Lt -> succ (sqrt (pred a))
-    | _ -> Z0
-  
-  (** val log2_up : z -> z **)
-  
-  let log2_up a =
-    match compare (Zpos XH) a with
-    | Lt -> succ (log2 (pred a))
-    | _ -> Z0
-  
-  module NZDivP = 
-   struct 
-    
-   end
-  
-  module Quot2Div = 
-   struct 
-    (** val div : z -> z -> z **)
-    
-    let div =
-      quot
-    
-    (** val modulo : z -> z -> z **)
-    
-    let modulo =
-      rem
-   end
-  
-  module NZQuot = 
-   struct 
-    
-   end
-  
-  (** val lcm : z -> z -> z **)
-  
-  let lcm a b =
-    abs (mul a (div b (gcd a b)))
-  
-  (** val b2z : bool -> z **)
-  
-  let b2z = function
-  | true -> Zpos XH
-  | false -> Z0
-  
-  (** val setbit : z -> z -> z **)
-  
-  let setbit a n0 =
-    coq_lor a (shiftl (Zpos XH) n0)
-  
-  (** val clearbit : z -> z -> z **)
-  
-  let clearbit a n0 =
-    ldiff a (shiftl (Zpos XH) n0)
-  
-  (** val lnot : z -> z **)
-  
-  let lnot a =
-    pred (opp a)
-  
-  (** val ones : z -> z **)
-  
-  let ones n0 =
-    pred (shiftl (Zpos XH) n0)
-  
-  module T = 
-   struct 
-    
-   end
-  
-  module ORev = 
-   struct 
-    type t = z
-   end
-  
-  module MRev = 
-   struct 
-    (** val max : z -> z -> z **)
-    
-    let max x y =
-      min y x
-   end
-  
-  module MPRev = MaxLogicalProperties(ORev)(MRev)
-  
-  module P = 
-   struct 
-    (** val max_case_strong :
-        z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1)
-        -> 'a1 **)
-    
-    let max_case_strong n0 m compat hl hr =
-      let c = compSpec2Type n0 m (compare n0 m) in
-      (match c with
-       | CompGtT -> compat n0 (max n0 m) __ (hl __)
-       | _ -> compat m (max n0 m) __ (hr __))
-    
-    (** val max_case :
-        z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **)
-    
-    let max_case n0 m x x0 x1 =
-      max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1)
-    
-    (** val max_dec : z -> z -> bool **)
-    
-    let max_dec n0 m =
-      max_case n0 m (fun x y _ h0 -> h0) true false
-    
-    (** val min_case_strong :
-        z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1)
-        -> 'a1 **)
-    
-    let min_case_strong n0 m compat hl hr =
-      let c = compSpec2Type n0 m (compare n0 m) in
-      (match c with
-       | CompGtT -> compat m (min n0 m) __ (hr __)
-       | _ -> compat n0 (min n0 m) __ (hl __))
-    
-    (** val min_case :
-        z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **)
-    
-    let min_case n0 m x x0 x1 =
-      min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1)
-    
-    (** val min_dec : z -> z -> bool **)
-    
-    let min_dec n0 m =
-      min_case n0 m (fun x y _ h0 -> h0) true false
-   end
-  
-  (** val max_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
-  
-  let max_case_strong n0 m x x0 =
-    P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0
-  
-  (** val max_case : z -> z -> 'a1 -> 'a1 -> 'a1 **)
-  
-  let max_case n0 m x x0 =
-    max_case_strong n0 m (fun _ -> x) (fun _ -> x0)
-  
-  (** val max_dec : z -> z -> bool **)
-  
-  let max_dec =
-    P.max_dec
-  
-  (** val min_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
-  
-  let min_case_strong n0 m x x0 =
-    P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0
-  
-  (** val min_case : z -> z -> 'a1 -> 'a1 -> 'a1 **)
-  
-  let min_case n0 m x x0 =
-    min_case_strong n0 m (fun _ -> x) (fun _ -> x0)
-  
-  (** val min_dec : z -> z -> bool **)
-  
-  let min_dec =
-    P.min_dec
  end
 
 (** val zeq_bool : z -> z -> bool **)
@@ -2818,9 +555,9 @@ let rec peq ceqb p p' =
 (** val mkPinj : positive -> 'a1 pol -> 'a1 pol **)
 
 let mkPinj j p = match p with
-| Pc c -> p
+| Pc _ -> p
 | Pinj (j', q0) -> Pinj ((Coq_Pos.add j j'), q0)
-| PX (p2, p3, p4) -> Pinj (j, p)
+| PX (_, _, _) -> Pinj (j, p)
 
 (** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **)
 
@@ -2831,12 +568,13 @@ let mkPinj_pred j p =
   | XH -> p
 
 (** val mkPX :
-    'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
+    'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1
+    pol **)
 
 let mkPX cO ceqb p i q0 =
   match p with
   | Pc c -> if ceqb c cO then mkPinj XH q0 else PX (p, i, q0)
-  | Pinj (p2, p3) -> PX (p, i, q0)
+  | Pinj (_, _) -> PX (p, i, q0)
   | PX (p', i', q') ->
     if peq ceqb q' (p0 cO)
     then PX (p', (Coq_Pos.add i' i), q0)
@@ -2893,8 +631,8 @@ let rec paddI cadd pop q0 j = function
    | XH -> PX (p2, i, (pop q' q0)))
 
 (** val psubI :
-    ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) ->
-    'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
+    ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol)
+    -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
 
 let rec psubI cadd copp pop q0 j = function
 | Pc c -> mkPinj j (paddC cadd (popp copp q0) c)
@@ -2911,11 +649,11 @@ let rec psubI cadd copp pop q0 j = function
    | XH -> PX (p2, i, (pop q' q0)))
 
 (** val paddX :
-    'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol
-    -> positive -> 'a1 pol -> 'a1 pol **)
+    'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1
+    pol -> positive -> 'a1 pol -> 'a1 pol **)
 
 let rec paddX cO ceqb pop p' i' p = match p with
-| Pc c -> PX (p', i', p)
+| Pc _ -> PX (p', i', p)
 | Pinj (j, q') ->
   (match j with
    | XI j0 -> PX (p', i', (Pinj ((XO j0), q')))
@@ -2928,15 +666,16 @@ let rec paddX cO ceqb pop p' i' p = match p with
    | Zneg k -> mkPX cO ceqb (paddX cO ceqb pop p' k p2) i q')
 
 (** val psubX :
-    'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1
-    pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
+    'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol ->
+    'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
 
 let rec psubX cO copp ceqb pop p' i' p = match p with
-| Pc c -> PX ((popp copp p'), i', p)
+| Pc _ -> PX ((popp copp p'), i', p)
 | Pinj (j, q') ->
   (match j with
    | XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q')))
-   | XO j0 -> PX ((popp copp p'), i', (Pinj ((Coq_Pos.pred_double j0), q')))
+   | XO j0 ->
+     PX ((popp copp p'), i', (Pinj ((Coq_Pos.pred_double j0), q')))
    | XH -> PX ((popp copp p'), i', q'))
 | PX (p2, i, q') ->
   (match Z.pos_sub i i' with
@@ -2945,8 +684,8 @@ let rec psubX cO copp ceqb pop p' i' p = match p with
    | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb pop p' k p2) i q')
 
 (** val padd :
-    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol
-    -> 'a1 pol **)
+    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1
+    pol -> 'a1 pol **)
 
 let rec padd cO cadd ceqb p = function
 | Pc c' -> paddC cadd p c'
@@ -2964,7 +703,8 @@ let rec padd cO cadd ceqb p = function
    | PX (p2, i, q0) ->
      (match Z.pos_sub i i' with
       | Z0 ->
-        mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i (padd cO cadd ceqb q0 q')
+        mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i
+          (padd cO cadd ceqb q0 q')
       | Zpos k ->
         mkPX cO ceqb (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i'
           (padd cO cadd ceqb q0 q')
@@ -2973,8 +713,8 @@ let rec padd cO cadd ceqb p = function
           (padd cO cadd ceqb q0 q')))
 
 (** val psub :
-    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
-    -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **)
+    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) ->
+    ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **)
 
 let rec psub cO cadd csub copp ceqb p = function
 | Pc c' -> psubC csub p c'
@@ -2989,25 +729,27 @@ let rec psub cO cadd csub copp ceqb p = function
           (psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q'))
       | XO j0 ->
         PX ((popp copp p'0), i',
-          (psub cO cadd csub copp ceqb (Pinj ((Coq_Pos.pred_double j0), q0))
-            q'))
-      | XH -> PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb q0 q')))
+          (psub cO cadd csub copp ceqb (Pinj ((Coq_Pos.pred_double j0),
+            q0)) q'))
+      | XH ->
+        PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb q0 q')))
    | PX (p2, i, q0) ->
      (match Z.pos_sub i i' with
       | Z0 ->
         mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i
           (psub cO cadd csub copp ceqb q0 q')
       | Zpos k ->
-        mkPX cO ceqb (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0)
-          i' (psub cO cadd csub copp ceqb q0 q')
+        mkPX cO ceqb
+          (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0) i'
+          (psub cO cadd csub copp ceqb q0 q')
       | Zneg k ->
         mkPX cO ceqb
           (psubX cO copp ceqb (psub cO cadd csub copp ceqb) p'0 k p2) i
           (psub cO cadd csub copp ceqb q0 q')))
 
 (** val pmulC_aux :
-    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 ->
-    'a1 pol **)
+    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1
+    -> 'a1 pol **)
 
 let rec pmulC_aux cO cmul ceqb p c =
   match p with
@@ -3018,8 +760,8 @@ let rec pmulC_aux cO cmul ceqb p c =
       (pmulC_aux cO cmul ceqb q0 c)
 
 (** val pmulC :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol ->
-    'a1 -> 'a1 pol **)
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol
+    -> 'a1 -> 'a1 pol **)
 
 let pmulC cO cI cmul ceqb p c =
   if ceqb c cO
@@ -3027,8 +769,8 @@ let pmulC cO cI cmul ceqb p c =
   else if ceqb c cI then p else pmulC_aux cO cmul ceqb p c
 
 (** val pmulI :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol ->
-    'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol
+    -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
 
 let rec pmulI cO cI cmul ceqb pmul0 q0 j = function
 | Pc c -> mkPinj j (pmulC cO cI cmul ceqb q0 c)
@@ -3049,12 +791,13 @@ let rec pmulI cO cI cmul ceqb pmul0 q0 j = function
      mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 XH p') i' (pmul0 q' q0))
 
 (** val pmul :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
-    -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **)
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+    'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **)
 
 let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with
 | Pc c -> pmulC cO cI cmul ceqb p c
-| Pinj (j', q') -> pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' j' p
+| Pinj (j', q') ->
+  pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' j' p
 | PX (p', i', q') ->
   (match p with
    | Pc c -> pmulC cO cI cmul ceqb p'' c
@@ -3063,22 +806,24 @@ let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with
        match j with
        | XI j0 -> pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q'
        | XO j0 ->
-         pmul cO cI cadd cmul ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) q'
+         pmul cO cI cadd cmul ceqb (Pinj ((Coq_Pos.pred_double j0), q0))
+           q'
        | XH -> pmul cO cI cadd cmul ceqb q0 q'
      in
      mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i' qQ'
    | PX (p2, i, q0) ->
      let qQ' = pmul cO cI cadd cmul ceqb q0 q' in
-     let pQ' = pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' XH p2 in
+     let pQ' = pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' XH p2
+     in
      let qP' = pmul cO cI cadd cmul ceqb (mkPinj XH q0) p' in
      let pP' = pmul cO cI cadd cmul ceqb p2 p' in
      padd cO cadd ceqb
-       (mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb pP' i (p0 cO)) qP') i'
-         (p0 cO)) (mkPX cO ceqb pQ' i qQ'))
+       (mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb pP' i (p0 cO)) qP')
+         i' (p0 cO)) (mkPX cO ceqb pQ' i qQ'))
 
 (** val psquare :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
-    -> bool) -> 'a1 pol -> 'a1 pol **)
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+    'a1 -> bool) -> 'a1 pol -> 'a1 pol **)
 
 let rec psquare cO cI cadd cmul ceqb = function
 | Pc c -> Pc (cmul c c)
@@ -3107,9 +852,9 @@ let mk_X cO cI j =
   mkPinj_pred j (mkX cO cI)
 
 (** val ppow_pos :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
-    -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1
-    pol **)
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+    'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive
+    -> 'a1 pol **)
 
 let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function
 | XI p3 ->
@@ -3123,16 +868,17 @@ let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function
 | XH -> subst_l (pmul cO cI cadd cmul ceqb res p)
 
 (** val ppow_N :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
-    -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol **)
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+    'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol **)
 
 let ppow_N cO cI cadd cmul ceqb subst_l p = function
 | N0 -> p1 cI
 | Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2
 
 (** val norm_aux :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
-    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **)
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+    'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr ->
+    'a1 pol **)
 
 let rec norm_aux cO cI cadd cmul csub copp ceqb = function
 | PEc c -> Pc c
@@ -3153,7 +899,8 @@ let rec norm_aux cO cI cadd cmul csub copp ceqb = function
         padd cO cadd ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1)
           (norm_aux cO cI cadd cmul csub copp ceqb pe2)))
 | PEsub (pe1, pe2) ->
-  psub cO cadd csub copp ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1)
+  psub cO cadd csub copp ceqb
+    (norm_aux cO cI cadd cmul csub copp ceqb pe1)
     (norm_aux cO cI cadd cmul csub copp ceqb pe2)
 | PEmul (pe1, pe2) ->
   pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1)
@@ -3185,9 +932,9 @@ let rec map_bformula fct = function
 | N f0 -> N (map_bformula fct f0)
 | I (f1, f2) -> I ((map_bformula fct f1), (map_bformula fct f2))
 
-type 'term' clause = 'term' list
+type 'x clause = 'x list
 
-type 'term' cnf = 'term' clause list
+type 'x cnf = 'x clause list
 
 (** val tt : 'a1 cnf **)
 
@@ -3200,52 +947,52 @@ let ff =
   []::[]
 
 (** val add_term :
-    ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1
-    clause option **)
+    ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause ->
+    'a1 clause option **)
 
-let rec add_term unsat deduce t1 = function
+let rec add_term unsat deduce t0 = function
 | [] ->
-  (match deduce t1 t1 with
-   | Some u -> if unsat u then None else Some (t1::[])
-   | None -> Some (t1::[]))
+  (match deduce t0 t0 with
+   | Some u -> if unsat u then None else Some (t0::[])
+   | None -> Some (t0::[]))
 | t'::cl0 ->
-  (match deduce t1 t' with
+  (match deduce t0 t' with
    | Some u ->
      if unsat u
      then None
-     else (match add_term unsat deduce t1 cl0 with
+     else (match add_term unsat deduce t0 cl0 with
            | Some cl' -> Some (t'::cl')
            | None -> None)
    | None ->
-     (match add_term unsat deduce t1 cl0 with
+     (match add_term unsat deduce t0 cl0 with
       | Some cl' -> Some (t'::cl')
       | None -> None))
 
 (** val or_clause :
-    ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause
-    -> 'a1 clause option **)
+    ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1
+    clause -> 'a1 clause option **)
 
 let rec or_clause unsat deduce cl1 cl2 =
   match cl1 with
   | [] -> Some cl2
-  | t1::cl ->
-    (match add_term unsat deduce t1 cl2 with
+  | t0::cl ->
+    (match add_term unsat deduce t0 cl2 with
      | Some cl' -> or_clause unsat deduce cl cl'
      | None -> None)
 
 (** val or_clause_cnf :
-    ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf ->
-    'a1 cnf **)
+    ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf
+    -> 'a1 cnf **)
 
-let or_clause_cnf unsat deduce t1 f =
+let or_clause_cnf unsat deduce t0 f =
   fold_right (fun e acc ->
-    match or_clause unsat deduce t1 e with
+    match or_clause unsat deduce t0 e with
     | Some cl -> cl::acc
     | None -> acc) [] f
 
 (** val or_cnf :
-    ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1
-    cnf **)
+    ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf ->
+    'a1 cnf **)
 
 let rec or_cnf unsat deduce f f' =
   match f with
@@ -3259,8 +1006,8 @@ let and_cnf f1 f2 =
   app f1 f2
 
 (** val xcnf :
-    ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1
-    -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **)
+    ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) ->
+    ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **)
 
 let rec xcnf unsat deduce normalise0 negate0 pol0 = function
 | TT -> if pol0 then tt else ff
@@ -3300,9 +1047,9 @@ let rec cnf_checker checker f l =
      | c::l0 -> if checker e c then cnf_checker checker f0 l0 else false)
 
 (** val tauto_checker :
-    ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1
-    -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list ->
-    bool **)
+    ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) ->
+    ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3
+    list -> bool **)
 
 let tauto_checker unsat deduce normalise0 negate0 checker f w =
   cnf_checker checker (xcnf unsat deduce normalise0 negate0 true f) w
@@ -3335,18 +1082,18 @@ let opMult o o' =
   | Equal -> Some Equal
   | NonEqual ->
     (match o' with
-     | Strict -> None
-     | NonStrict -> None
-     | x -> Some x)
+     | Equal -> Some Equal
+     | NonEqual -> Some NonEqual
+     | _ -> None)
   | Strict ->
     (match o' with
      | NonEqual -> None
      | _ -> Some o')
   | NonStrict ->
     (match o' with
+     | Equal -> Some Equal
      | NonEqual -> None
-     | Strict -> Some NonStrict
-     | x -> Some x)
+     | _ -> Some NonStrict)
 
 (** val opAdd : op1 -> op1 -> op1 option **)
 
@@ -3394,8 +1141,8 @@ let map_option2 f o o' =
   | None -> None
 
 (** val pexpr_times_nformula :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
-    -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option **)
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+    'a1 -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option **)
 
 let pexpr_times_nformula cO cI cplus ctimes ceqb e = function
 | ef,o ->
@@ -3404,8 +1151,8 @@ let pexpr_times_nformula cO cI cplus ctimes ceqb e = function
    | _ -> None)
 
 (** val nformula_times_nformula :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
-    -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **)
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+    'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **)
 
 let nformula_times_nformula cO cI cplus ctimes ceqb f1 f2 =
   let e1,o1 = f1 in
@@ -3414,8 +1161,8 @@ let nformula_times_nformula cO cI cplus ctimes ceqb f1 f2 =
     (opMult o1 o2)
 
 (** val nformula_plus_nformula :
-    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1
-    nFormula -> 'a1 nFormula option **)
+    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula ->
+    'a1 nFormula -> 'a1 nFormula option **)
 
 let nformula_plus_nformula cO cplus ceqb f1 f2 =
   let e1,o1 = f1 in
@@ -3423,9 +1170,9 @@ let nformula_plus_nformula cO cplus ceqb f1 f2 =
   map_option (fun x -> Some ((padd cO cplus ceqb e1 e2),x)) (opAdd o1 o2)
 
 (** val eval_Psatz :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
-    -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1
-    nFormula option **)
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+    'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz
+    -> 'a1 nFormula option **)
 
 let rec eval_Psatz cO cI cplus ctimes ceqb cleb l = function
 | PsatzIn n0 -> Some (nth n0 l ((Pc cO),Equal))
@@ -3460,9 +1207,9 @@ let check_inconsistent cO ceqb cleb = function
    | _ -> false)
 
 (** val check_normalised_formulas :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
-    -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz ->
-    bool **)
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+    'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz
+    -> bool **)
 
 let check_normalised_formulas cO cI cplus ctimes ceqb cleb l cm =
   match eval_Psatz cO cI cplus ctimes ceqb cleb l cm with
@@ -3479,51 +1226,41 @@ type op2 =
 
 type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr }
 
-(** val flhs : 'a1 formula -> 'a1 pExpr **)
-
-let flhs x = x.flhs
-
-(** val fop : 'a1 formula -> op2 **)
-
-let fop x = x.fop
-
-(** val frhs : 'a1 formula -> 'a1 pExpr **)
-
-let frhs x = x.frhs
-
 (** val norm :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
-    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **)
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+    'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr ->
+    'a1 pol **)
 
 let norm cO cI cplus ctimes cminus copp ceqb =
   norm_aux cO cI cplus ctimes cminus copp ceqb
 
 (** val psub0 :
-    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
-    -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **)
+    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) ->
+    ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **)
 
 let psub0 cO cplus cminus copp ceqb =
   psub cO cplus cminus copp ceqb
 
 (** val padd0 :
-    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol
-    -> 'a1 pol **)
+    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1
+    pol -> 'a1 pol **)
 
 let padd0 cO cplus ceqb =
   padd cO cplus ceqb
 
 (** val xnormalise :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
-    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
-    nFormula list **)
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+    'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula ->
+    'a1 nFormula list **)
 
-let xnormalise cO cI cplus ctimes cminus copp ceqb t1 =
-  let { flhs = lhs; fop = o; frhs = rhs } = t1 in
+let xnormalise cO cI cplus ctimes cminus copp ceqb t0 =
+  let { flhs = lhs; fop = o; frhs = rhs } = t0 in
   let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in
   let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in
   (match o with
    | OpEq ->
-     ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO cplus
+     ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO
+                                                               cplus
                                                                cminus copp
                                                                ceqb rhs0
                                                                lhs0),Strict)::[])
@@ -3534,26 +1271,27 @@ let xnormalise cO cI cplus ctimes cminus copp ceqb t1 =
    | OpGt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict)::[])
 
 (** val cnf_normalise :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
-    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
-    nFormula cnf **)
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+    'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula ->
+    'a1 nFormula cnf **)
 
-let cnf_normalise cO cI cplus ctimes cminus copp ceqb t1 =
-  map (fun x -> x::[]) (xnormalise cO cI cplus ctimes cminus copp ceqb t1)
+let cnf_normalise cO cI cplus ctimes cminus copp ceqb t0 =
+  map (fun x -> x::[]) (xnormalise cO cI cplus ctimes cminus copp ceqb t0)
 
 (** val xnegate :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
-    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
-    nFormula list **)
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+    'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula ->
+    'a1 nFormula list **)
 
-let xnegate cO cI cplus ctimes cminus copp ceqb t1 =
-  let { flhs = lhs; fop = o; frhs = rhs } = t1 in
+let xnegate cO cI cplus ctimes cminus copp ceqb t0 =
+  let { flhs = lhs; fop = o; frhs = rhs } = t0 in
   let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in
   let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in
   (match o with
    | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal)::[]
    | OpNEq ->
-     ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO cplus
+     ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO
+                                                               cplus
                                                                cminus copp
                                                                ceqb rhs0
                                                                lhs0),Strict)::[])
@@ -3563,12 +1301,12 @@ let xnegate cO cI cplus ctimes cminus copp ceqb t1 =
    | OpGt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::[])
 
 (** val cnf_negate :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
-    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
-    nFormula cnf **)
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+    'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula ->
+    'a1 nFormula cnf **)
 
-let cnf_negate cO cI cplus ctimes cminus copp ceqb t1 =
-  map (fun x -> x::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t1)
+let cnf_negate cO cI cplus ctimes cminus copp ceqb t0 =
+  map (fun x -> x::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t0)
 
 (** val xdenorm : positive -> 'a1 pol -> 'a1 pExpr **)
 
@@ -3602,14 +1340,14 @@ let map_Formula c_of_S f =
   { flhs = (map_PExpr c_of_S l); fop = o; frhs = (map_PExpr c_of_S r) }
 
 (** val simpl_cone :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz ->
-    'a1 psatz **)
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz
+    -> 'a1 psatz **)
 
 let simpl_cone cO cI ctimes ceqb e = match e with
-| PsatzSquare t1 ->
-  (match t1 with
+| PsatzSquare t0 ->
+  (match t0 with
    | Pc c -> if ceqb cO c then PsatzZ else PsatzC (ctimes c c)
-   | _ -> PsatzSquare t1)
+   | _ -> PsatzSquare t0)
 | PsatzMulE (t1, t2) ->
   (match t1 with
    | PsatzMulE (x, x0) ->
@@ -3641,7 +1379,8 @@ let simpl_cone cO cI ctimes ceqb e = match e with
             | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x)
             | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2)))
       | PsatzAdd (y, z0) ->
-        PsatzAdd ((PsatzMulE ((PsatzC c), y)), (PsatzMulE ((PsatzC c), z0)))
+        PsatzAdd ((PsatzMulE ((PsatzC c), y)), (PsatzMulE ((PsatzC c),
+          z0)))
       | PsatzC c0 -> PsatzC (ctimes c c0)
       | PsatzZ -> PsatzZ
       | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2))
@@ -3683,7 +1422,8 @@ let qle_bool x y =
 (** val qplus : q -> q -> q **)
 
 let qplus x y =
-  { qnum = (Z.add (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)));
+  { qnum =
+    (Z.add (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)));
     qden = (Coq_Pos.mul x.qden y.qden) }
 
 (** val qmult : q -> q -> q **)
@@ -3711,8 +1451,8 @@ let qinv x =
 
 (** val qpower_positive : q -> positive -> q **)
 
-let qpower_positive q0 p =
-  pow_pos qmult q0 p
+let qpower_positive =
+  pow_pos qmult
 
 (** val qpower : q -> z -> q **)
 
@@ -3721,12 +1461,12 @@ let qpower q0 = function
 | Zpos p -> qpower_positive q0 p
 | Zneg p -> qinv (qpower_positive q0 p)
 
-type 'a t0 =
+type 'a t =
 | Empty
 | Leaf of 'a
-| Node of 'a t0 * 'a * 'a t0
+| Node of 'a t * 'a * 'a t
 
-(** val find : 'a1 -> 'a1 t0 -> positive -> 'a1 **)
+(** val find : 'a1 -> 'a1 t -> positive -> 'a1 **)
 
 let rec find default vm p =
   match vm with
@@ -3738,6 +1478,29 @@ let rec find default vm p =
      | XO p2 -> find default l p2
      | XH -> e)
 
+(** val singleton : 'a1 -> positive -> 'a1 -> 'a1 t **)
+
+let rec singleton default x v =
+  match x with
+  | XI p -> Node (Empty, default, (singleton default p v))
+  | XO p -> Node ((singleton default p v), default, Empty)
+  | XH -> Leaf v
+
+(** val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t **)
+
+let rec vm_add default x v = function
+| Empty -> singleton default x v
+| Leaf vl ->
+  (match x with
+   | XI p -> Node (Empty, vl, (singleton default p v))
+   | XO p -> Node ((singleton default p v), vl, Empty)
+   | XH -> Leaf v)
+| Node (l, o, r) ->
+  (match x with
+   | XI p -> Node (l, o, (vm_add default p v r))
+   | XO p -> Node ((vm_add default p v l), o, r)
+   | XH -> Node (l, v, r))
+
 type zWitness = z psatz
 
 (** val zWeakChecker : z nFormula list -> z psatz -> bool **)
@@ -3762,8 +1525,8 @@ let norm0 =
 
 (** val xnormalise0 : z formula -> z nFormula list **)
 
-let xnormalise0 t1 =
-  let { flhs = lhs; fop = o; frhs = rhs } = t1 in
+let xnormalise0 t0 =
+  let { flhs = lhs; fop = o; frhs = rhs } = t0 in
   let lhs0 = norm0 lhs in
   let rhs0 = norm0 rhs in
   (match o with
@@ -3780,13 +1543,13 @@ let xnormalise0 t1 =
 
 (** val normalise : z formula -> z nFormula cnf **)
 
-let normalise t1 =
-  map (fun x -> x::[]) (xnormalise0 t1)
+let normalise t0 =
+  map (fun x -> x::[]) (xnormalise0 t0)
 
 (** val xnegate0 : z formula -> z nFormula list **)
 
-let xnegate0 t1 =
-  let { flhs = lhs; fop = o; frhs = rhs } = t1 in
+let xnegate0 t0 =
+  let { flhs = lhs; fop = o; frhs = rhs } = t0 in
   let lhs0 = norm0 lhs in
   let rhs0 = norm0 rhs in
   (match o with
@@ -3803,8 +1566,8 @@ let xnegate0 t1 =
 
 (** val negate : z formula -> z nFormula cnf **)
 
-let negate t1 =
-  map (fun x -> x::[]) (xnegate0 t1)
+let negate t0 =
+  map (fun x -> x::[]) (xnegate0 t0)
 
 (** val zunsat : z nFormula -> bool **)
 
@@ -3839,8 +1602,8 @@ let zgcdM x y =
 
 let rec zgcd_pol = function
 | Pc c -> Z0,c
-| Pinj (p2, p3) -> zgcd_pol p3
-| PX (p2, p3, q0) ->
+| Pinj (_, p2) -> zgcd_pol p2
+| PX (p2, _, q0) ->
   let g1,c1 = zgcd_pol p2 in
   let g2,c2 = zgcd_pol q0 in (zgcdM (zgcdM g1 c1) g2),c2
 
@@ -3872,7 +1635,8 @@ let genCuttingPlane = function
      then None
      else Some ((makeCuttingPlane e),Equal)
    | NonEqual -> Some ((e,Z0),op)
-   | Strict -> Some ((makeCuttingPlane (psubC Z.sub e (Zpos XH))),NonStrict)
+   | Strict ->
+     Some ((makeCuttingPlane (psubC Z.sub e (Zpos XH))),NonStrict)
    | NonStrict -> Some ((makeCuttingPlane e),NonStrict))
 
 (** val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula **)
@@ -3966,8 +1730,8 @@ let qnormalise =
 (** val qnegate : q formula -> q nFormula cnf **)
 
 let qnegate =
-  cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus
-    qmult qminus qopp qeq_bool
+  cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH }
+    qplus qmult qminus qopp qeq_bool
 
 (** val qunsat : q nFormula -> bool **)
 
@@ -4025,8 +1789,8 @@ let rnormalise =
 (** val rnegate : q formula -> q nFormula cnf **)
 
 let rnegate =
-  cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus
-    qmult qminus qopp qeq_bool
+  cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH }
+    qplus qmult qminus qopp qeq_bool
 
 (** val runsat : q nFormula -> bool **)
 
@@ -4043,4 +1807,3 @@ let rdeduce =
 let rTautoChecker f w =
   tauto_checker runsat rdeduce rnormalise rnegate rWeakChecker
     (map_bformula (map_Formula q_of_Rcst) f) w
-
diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli
index bcd61f39..beb042f4 100644
--- a/plugins/micromega/micromega.mli
+++ b/plugins/micromega/micromega.mli
@@ -1,15 +1,9 @@
-type __ = Obj.t
-
 val negb : bool -> bool
 
 type nat =
 | O
 | S of nat
 
-val fst : ('a1 * 'a2) -> 'a1
-
-val snd : ('a1 * 'a2) -> 'a2
-
 val app : 'a1 list -> 'a1 list -> 'a1 list
 
 type comparison =
@@ -19,24 +13,7 @@ type comparison =
 
 val compOpp : comparison -> comparison
 
-type compareSpecT =
-| CompEqT
-| CompLtT
-| CompGtT
-
-val compareSpec2Type : comparison -> compareSpecT
-
-type 'a compSpecT = compareSpecT
-
-val compSpec2Type : 'a1 -> 'a1 -> comparison -> 'a1 compSpecT
-
-type 'a sig0 =
-  'a
-  (* singleton inductive, whose constructor was exist *)
-
-val plus : nat -> nat -> nat
-
-val nat_iter : nat -> ('a1 -> 'a1) -> 'a1 -> 'a1
+val add : nat -> nat -> nat
 
 type positive =
 | XI of positive
@@ -52,560 +29,59 @@ type z =
 | Zpos of positive
 | Zneg of positive
 
-module type TotalOrder' = 
- sig 
-  type t 
- end
-
-module MakeOrderTac : 
- functor (O:TotalOrder') ->
- sig 
-  
- end
-
-module MaxLogicalProperties : 
- functor (O:TotalOrder') ->
- functor (M:sig 
-  val max : O.t -> O.t -> O.t
- end) ->
- sig 
-  module T : 
-   sig 
-    
-   end
- end
-
-module Pos : 
- sig 
-  type t = positive
-  
-  val succ : positive -> positive
-  
-  val add : positive -> positive -> positive
-  
-  val add_carry : positive -> positive -> positive
-  
-  val pred_double : positive -> positive
-  
-  val pred : positive -> positive
-  
-  val pred_N : positive -> n
-  
+module Pos :
+ sig
   type mask =
   | IsNul
   | IsPos of positive
   | IsNeg
-  
-  val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1
-  
-  val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1
-  
-  val succ_double_mask : mask -> mask
-  
-  val double_mask : mask -> mask
-  
-  val double_pred_mask : positive -> mask
-  
-  val pred_mask : mask -> mask
-  
-  val sub_mask : positive -> positive -> mask
-  
-  val sub_mask_carry : positive -> positive -> mask
-  
-  val sub : positive -> positive -> positive
-  
-  val mul : positive -> positive -> positive
-  
-  val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1
-  
-  val pow : positive -> positive -> positive
-  
-  val div2 : positive -> positive
-  
-  val div2_up : positive -> positive
-  
-  val size_nat : positive -> nat
-  
-  val size : positive -> positive
-  
-  val compare_cont : positive -> positive -> comparison -> comparison
-  
-  val compare : positive -> positive -> comparison
-  
-  val min : positive -> positive -> positive
-  
-  val max : positive -> positive -> positive
-  
-  val eqb : positive -> positive -> bool
-  
-  val leb : positive -> positive -> bool
-  
-  val ltb : positive -> positive -> bool
-  
-  val sqrtrem_step :
-    (positive -> positive) -> (positive -> positive) -> (positive * mask) ->
-    positive * mask
-  
-  val sqrtrem : positive -> positive * mask
-  
-  val sqrt : positive -> positive
-  
-  val gcdn : nat -> positive -> positive -> positive
-  
-  val gcd : positive -> positive -> positive
-  
-  val ggcdn : nat -> positive -> positive -> positive * (positive * positive)
-  
-  val ggcd : positive -> positive -> positive * (positive * positive)
-  
-  val coq_Nsucc_double : n -> n
-  
-  val coq_Ndouble : n -> n
-  
-  val coq_lor : positive -> positive -> positive
-  
-  val coq_land : positive -> positive -> n
-  
-  val ldiff : positive -> positive -> n
-  
-  val coq_lxor : positive -> positive -> n
-  
-  val shiftl_nat : positive -> nat -> positive
-  
-  val shiftr_nat : positive -> nat -> positive
-  
-  val shiftl : positive -> n -> positive
-  
-  val shiftr : positive -> n -> positive
-  
-  val testbit_nat : positive -> nat -> bool
-  
-  val testbit : positive -> n -> bool
-  
-  val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1
-  
-  val to_nat : positive -> nat
-  
-  val of_nat : nat -> positive
-  
-  val of_succ_nat : nat -> positive
  end
 
-module Coq_Pos : 
- sig 
-  module Coq__1 : sig 
-   type t = positive
-  end
-  type t = Coq__1.t
-  
+module Coq_Pos :
+ sig
   val succ : positive -> positive
-  
+
   val add : positive -> positive -> positive
-  
+
   val add_carry : positive -> positive -> positive
-  
+
   val pred_double : positive -> positive
-  
-  val pred : positive -> positive
-  
-  val pred_N : positive -> n
-  
+
   type mask = Pos.mask =
   | IsNul
   | IsPos of positive
   | IsNeg
-  
-  val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1
-  
-  val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1
-  
+
   val succ_double_mask : mask -> mask
-  
+
   val double_mask : mask -> mask
-  
+
   val double_pred_mask : positive -> mask
-  
-  val pred_mask : mask -> mask
-  
+
   val sub_mask : positive -> positive -> mask
-  
+
   val sub_mask_carry : positive -> positive -> mask
-  
+
   val sub : positive -> positive -> positive
-  
+
   val mul : positive -> positive -> positive
-  
-  val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1
-  
-  val pow : positive -> positive -> positive
-  
-  val div2 : positive -> positive
-  
-  val div2_up : positive -> positive
-  
+
   val size_nat : positive -> nat
-  
-  val size : positive -> positive
-  
-  val compare_cont : positive -> positive -> comparison -> comparison
-  
+
+  val compare_cont : comparison -> positive -> positive -> comparison
+
   val compare : positive -> positive -> comparison
-  
-  val min : positive -> positive -> positive
-  
-  val max : positive -> positive -> positive
-  
-  val eqb : positive -> positive -> bool
-  
-  val leb : positive -> positive -> bool
-  
-  val ltb : positive -> positive -> bool
-  
-  val sqrtrem_step :
-    (positive -> positive) -> (positive -> positive) -> (positive * mask) ->
-    positive * mask
-  
-  val sqrtrem : positive -> positive * mask
-  
-  val sqrt : positive -> positive
-  
+
   val gcdn : nat -> positive -> positive -> positive
-  
+
   val gcd : positive -> positive -> positive
-  
-  val ggcdn : nat -> positive -> positive -> positive * (positive * positive)
-  
-  val ggcd : positive -> positive -> positive * (positive * positive)
-  
-  val coq_Nsucc_double : n -> n
-  
-  val coq_Ndouble : n -> n
-  
-  val coq_lor : positive -> positive -> positive
-  
-  val coq_land : positive -> positive -> n
-  
-  val ldiff : positive -> positive -> n
-  
-  val coq_lxor : positive -> positive -> n
-  
-  val shiftl_nat : positive -> nat -> positive
-  
-  val shiftr_nat : positive -> nat -> positive
-  
-  val shiftl : positive -> n -> positive
-  
-  val shiftr : positive -> n -> positive
-  
-  val testbit_nat : positive -> nat -> bool
-  
-  val testbit : positive -> n -> bool
-  
-  val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1
-  
-  val to_nat : positive -> nat
-  
-  val of_nat : nat -> positive
-  
+
   val of_succ_nat : nat -> positive
-  
-  val eq_dec : positive -> positive -> bool
-  
-  val peano_rect : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1
-  
-  val peano_rec : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1
-  
-  type coq_PeanoView =
-  | PeanoOne
-  | PeanoSucc of positive * coq_PeanoView
-  
-  val coq_PeanoView_rect :
-    'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive ->
-    coq_PeanoView -> 'a1
-  
-  val coq_PeanoView_rec :
-    'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive ->
-    coq_PeanoView -> 'a1
-  
-  val peanoView_xO : positive -> coq_PeanoView -> coq_PeanoView
-  
-  val peanoView_xI : positive -> coq_PeanoView -> coq_PeanoView
-  
-  val peanoView : positive -> coq_PeanoView
-  
-  val coq_PeanoView_iter :
-    'a1 -> (positive -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1
-  
-  val switch_Eq : comparison -> comparison -> comparison
-  
-  val mask2cmp : mask -> comparison
-  
-  module T : 
-   sig 
-    
-   end
-  
-  module ORev : 
-   sig 
-    type t = Coq__1.t
-   end
-  
-  module MRev : 
-   sig 
-    val max : t -> t -> t
-   end
-  
-  module MPRev : 
-   sig 
-    module T : 
-     sig 
-      
-     end
-   end
-  
-  module P : 
-   sig 
-    val max_case_strong :
-      t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) ->
-      'a1
-    
-    val max_case :
-      t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1
-    
-    val max_dec : t -> t -> bool
-    
-    val min_case_strong :
-      t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) ->
-      'a1
-    
-    val min_case :
-      t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1
-    
-    val min_dec : t -> t -> bool
-   end
-  
-  val max_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
-  
-  val max_case : t -> t -> 'a1 -> 'a1 -> 'a1
-  
-  val max_dec : t -> t -> bool
-  
-  val min_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
-  
-  val min_case : t -> t -> 'a1 -> 'a1 -> 'a1
-  
-  val min_dec : t -> t -> bool
  end
 
-module N : 
- sig 
-  type t = n
-  
-  val zero : n
-  
-  val one : n
-  
-  val two : n
-  
-  val succ_double : n -> n
-  
-  val double : n -> n
-  
-  val succ : n -> n
-  
-  val pred : n -> n
-  
-  val succ_pos : n -> positive
-  
-  val add : n -> n -> n
-  
-  val sub : n -> n -> n
-  
-  val mul : n -> n -> n
-  
-  val compare : n -> n -> comparison
-  
-  val eqb : n -> n -> bool
-  
-  val leb : n -> n -> bool
-  
-  val ltb : n -> n -> bool
-  
-  val min : n -> n -> n
-  
-  val max : n -> n -> n
-  
-  val div2 : n -> n
-  
-  val even : n -> bool
-  
-  val odd : n -> bool
-  
-  val pow : n -> n -> n
-  
-  val log2 : n -> n
-  
-  val size : n -> n
-  
-  val size_nat : n -> nat
-  
-  val pos_div_eucl : positive -> n -> n * n
-  
-  val div_eucl : n -> n -> n * n
-  
-  val div : n -> n -> n
-  
-  val modulo : n -> n -> n
-  
-  val gcd : n -> n -> n
-  
-  val ggcd : n -> n -> n * (n * n)
-  
-  val sqrtrem : n -> n * n
-  
-  val sqrt : n -> n
-  
-  val coq_lor : n -> n -> n
-  
-  val coq_land : n -> n -> n
-  
-  val ldiff : n -> n -> n
-  
-  val coq_lxor : n -> n -> n
-  
-  val shiftl_nat : n -> nat -> n
-  
-  val shiftr_nat : n -> nat -> n
-  
-  val shiftl : n -> n -> n
-  
-  val shiftr : n -> n -> n
-  
-  val testbit_nat : n -> nat -> bool
-  
-  val testbit : n -> n -> bool
-  
-  val to_nat : n -> nat
-  
+module N :
+ sig
   val of_nat : nat -> n
-  
-  val iter : n -> ('a1 -> 'a1) -> 'a1 -> 'a1
-  
-  val eq_dec : n -> n -> bool
-  
-  val discr : n -> positive option
-  
-  val binary_rect : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1
-  
-  val binary_rec : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1
-  
-  val peano_rect : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1
-  
-  val peano_rec : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1
-  
-  module BootStrap : 
-   sig 
-    
-   end
-  
-  val recursion : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1
-  
-  module OrderElts : 
-   sig 
-    type t = n
-   end
-  
-  module OrderTac : 
-   sig 
-    
-   end
-  
-  module NZPowP : 
-   sig 
-    
-   end
-  
-  module NZSqrtP : 
-   sig 
-    
-   end
-  
-  val sqrt_up : n -> n
-  
-  val log2_up : n -> n
-  
-  module NZDivP : 
-   sig 
-    
-   end
-  
-  val lcm : n -> n -> n
-  
-  val b2n : bool -> n
-  
-  val setbit : n -> n -> n
-  
-  val clearbit : n -> n -> n
-  
-  val ones : n -> n
-  
-  val lnot : n -> n -> n
-  
-  module T : 
-   sig 
-    
-   end
-  
-  module ORev : 
-   sig 
-    type t = n
-   end
-  
-  module MRev : 
-   sig 
-    val max : n -> n -> n
-   end
-  
-  module MPRev : 
-   sig 
-    module T : 
-     sig 
-      
-     end
-   end
-  
-  module P : 
-   sig 
-    val max_case_strong :
-      n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) ->
-      'a1
-    
-    val max_case :
-      n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1
-    
-    val max_dec : n -> n -> bool
-    
-    val min_case_strong :
-      n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) ->
-      'a1
-    
-    val min_case :
-      n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1
-    
-    val min_dec : n -> n -> bool
-   end
-  
-  val max_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
-  
-  val max_case : n -> n -> 'a1 -> 'a1 -> 'a1
-  
-  val max_dec : n -> n -> bool
-  
-  val min_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
-  
-  val min_case : n -> n -> 'a1 -> 'a1 -> 'a1
-  
-  val min_dec : n -> n -> bool
  end
 
 val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1
@@ -616,225 +92,45 @@ val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list
 
 val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1
 
-module Z : 
- sig 
-  type t = z
-  
-  val zero : z
-  
-  val one : z
-  
-  val two : z
-  
+module Z :
+ sig
   val double : z -> z
-  
+
   val succ_double : z -> z
-  
+
   val pred_double : z -> z
-  
+
   val pos_sub : positive -> positive -> z
-  
+
   val add : z -> z -> z
-  
+
   val opp : z -> z
-  
-  val succ : z -> z
-  
-  val pred : z -> z
-  
+
   val sub : z -> z -> z
-  
+
   val mul : z -> z -> z
-  
-  val pow_pos : z -> positive -> z
-  
-  val pow : z -> z -> z
-  
+
   val compare : z -> z -> comparison
-  
-  val sgn : z -> z
-  
+
   val leb : z -> z -> bool
-  
-  val geb : z -> z -> bool
-  
+
   val ltb : z -> z -> bool
-  
+
   val gtb : z -> z -> bool
-  
-  val eqb : z -> z -> bool
-  
+
   val max : z -> z -> z
-  
-  val min : z -> z -> z
-  
+
   val abs : z -> z
-  
-  val abs_nat : z -> nat
-  
-  val abs_N : z -> n
-  
-  val to_nat : z -> nat
-  
+
   val to_N : z -> n
-  
-  val of_nat : nat -> z
-  
-  val of_N : n -> z
-  
-  val iter : z -> ('a1 -> 'a1) -> 'a1 -> 'a1
-  
+
   val pos_div_eucl : positive -> z -> z * z
-  
+
   val div_eucl : z -> z -> z * z
-  
+
   val div : z -> z -> z
-  
-  val modulo : z -> z -> z
-  
-  val quotrem : z -> z -> z * z
-  
-  val quot : z -> z -> z
-  
-  val rem : z -> z -> z
-  
-  val even : z -> bool
-  
-  val odd : z -> bool
-  
-  val div2 : z -> z
-  
-  val quot2 : z -> z
-  
-  val log2 : z -> z
-  
-  val sqrtrem : z -> z * z
-  
-  val sqrt : z -> z
-  
+
   val gcd : z -> z -> z
-  
-  val ggcd : z -> z -> z * (z * z)
-  
-  val testbit : z -> z -> bool
-  
-  val shiftl : z -> z -> z
-  
-  val shiftr : z -> z -> z
-  
-  val coq_lor : z -> z -> z
-  
-  val coq_land : z -> z -> z
-  
-  val ldiff : z -> z -> z
-  
-  val coq_lxor : z -> z -> z
-  
-  val eq_dec : z -> z -> bool
-  
-  module BootStrap : 
-   sig 
-    
-   end
-  
-  module OrderElts : 
-   sig 
-    type t = z
-   end
-  
-  module OrderTac : 
-   sig 
-    
-   end
-  
-  val sqrt_up : z -> z
-  
-  val log2_up : z -> z
-  
-  module NZDivP : 
-   sig 
-    
-   end
-  
-  module Quot2Div : 
-   sig 
-    val div : z -> z -> z
-    
-    val modulo : z -> z -> z
-   end
-  
-  module NZQuot : 
-   sig 
-    
-   end
-  
-  val lcm : z -> z -> z
-  
-  val b2z : bool -> z
-  
-  val setbit : z -> z -> z
-  
-  val clearbit : z -> z -> z
-  
-  val lnot : z -> z
-  
-  val ones : z -> z
-  
-  module T : 
-   sig 
-    
-   end
-  
-  module ORev : 
-   sig 
-    type t = z
-   end
-  
-  module MRev : 
-   sig 
-    val max : z -> z -> z
-   end
-  
-  module MPRev : 
-   sig 
-    module T : 
-     sig 
-      
-     end
-   end
-  
-  module P : 
-   sig 
-    val max_case_strong :
-      z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) ->
-      'a1
-    
-    val max_case :
-      z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1
-    
-    val max_dec : z -> z -> bool
-    
-    val min_case_strong :
-      z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) ->
-      'a1
-    
-    val min_case :
-      z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1
-    
-    val min_dec : z -> z -> bool
-   end
-  
-  val max_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
-  
-  val max_case : z -> z -> 'a1 -> 'a1 -> 'a1
-  
-  val max_dec : z -> z -> bool
-  
-  val min_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
-  
-  val min_case : z -> z -> 'a1 -> 'a1 -> 'a1
-  
-  val min_dec : z -> z -> bool
  end
 
 val zeq_bool : z -> z -> bool
@@ -872,44 +168,44 @@ val paddI :
   positive -> 'a1 pol -> 'a1 pol
 
 val psubI :
-  ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) ->
-  'a1 pol -> positive -> 'a1 pol -> 'a1 pol
+  ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol)
+  -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
 
 val paddX :
-  'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol
-  -> positive -> 'a1 pol -> 'a1 pol
+  'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1
+  pol -> positive -> 'a1 pol -> 'a1 pol
 
 val psubX :
-  'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1
-  pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
+  'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol ->
+  'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
 
 val padd :
-  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol ->
-  'a1 pol
+  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol
+  -> 'a1 pol
 
 val psub :
-  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
-  -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
+  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) ->
+  ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
 
 val pmulC_aux :
-  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1
-  pol
+  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 ->
+  'a1 pol
 
 val pmulC :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1
-  -> 'a1 pol
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol ->
+  'a1 -> 'a1 pol
 
 val pmulI :
   'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol ->
   'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
 
 val pmul :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
-  bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+  -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
 
 val psquare :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
-  bool) -> 'a1 pol -> 'a1 pol
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+  -> bool) -> 'a1 pol -> 'a1 pol
 
 type 'c pExpr =
 | PEc of 'c
@@ -923,16 +219,17 @@ type 'c pExpr =
 val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol
 
 val ppow_pos :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
-  bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+  -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive ->
+  'a1 pol
 
 val ppow_N :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
-  bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+  -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol
 
 val norm_aux :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
-  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+  -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol
 
 type 'a bFormula =
 | TT
@@ -946,9 +243,9 @@ type 'a bFormula =
 
 val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula
 
-type 'term' clause = 'term' list
+type 'x clause = 'x list
 
-type 'term' cnf = 'term' clause list
+type 'x cnf = 'x clause list
 
 val tt : 'a1 cnf
 
@@ -959,12 +256,12 @@ val add_term :
   clause option
 
 val or_clause :
-  ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause ->
-  'a1 clause option
+  ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause
+  -> 'a1 clause option
 
 val or_clause_cnf :
-  ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> 'a1
-  cnf
+  ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf ->
+  'a1 cnf
 
 val or_cnf :
   ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1
@@ -973,18 +270,20 @@ val or_cnf :
 val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf
 
 val xcnf :
-  ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 ->
-  'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf
+  ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1
+  -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf
 
 val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool
 
 val tauto_checker :
-  ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 ->
-  'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> bool
+  ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1
+  -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list ->
+  bool
 
 val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool
 
-val cltb : ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool
+val cltb :
+  ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool
 
 type 'c polC = 'c pol
 
@@ -1015,28 +314,30 @@ val map_option2 :
   ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option
 
 val pexpr_times_nformula :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
-  bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+  -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option
 
 val nformula_times_nformula :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
-  bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+  -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option
 
 val nformula_plus_nformula :
-  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1
-  nFormula -> 'a1 nFormula option
+  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula ->
+  'a1 nFormula -> 'a1 nFormula option
 
 val eval_Psatz :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
-  bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1
-  nFormula option
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+  -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz ->
+  'a1 nFormula option
 
 val check_inconsistent :
-  'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool
+  'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula ->
+  bool
 
 val check_normalised_formulas :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
-  bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+  -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz ->
+  bool
 
 type op2 =
 | OpEq
@@ -1048,43 +349,37 @@ type op2 =
 
 type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr }
 
-val flhs : 'a1 formula -> 'a1 pExpr
-
-val fop : 'a1 formula -> op2
-
-val frhs : 'a1 formula -> 'a1 pExpr
-
 val norm :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
-  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+  -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol
 
 val psub0 :
-  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
-  -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
+  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) ->
+  ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
 
 val padd0 :
-  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol ->
-  'a1 pol
+  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol
+  -> 'a1 pol
 
 val xnormalise :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
-  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula
-  list
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+  -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
+  nFormula list
 
 val cnf_normalise :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
-  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula
-  cnf
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+  -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
+  nFormula cnf
 
 val xnegate :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
-  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula
-  list
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+  -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
+  nFormula list
 
 val cnf_negate :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
-  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula
-  cnf
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+  -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
+  nFormula cnf
 
 val xdenorm : positive -> 'a1 pol -> 'a1 pExpr
 
@@ -1095,8 +390,8 @@ val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr
 val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula
 
 val simpl_cone :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz ->
-  'a1 psatz
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz
+  -> 'a1 psatz
 
 type q = { qnum : z; qden : positive }
 
@@ -1122,12 +417,16 @@ val qpower_positive : q -> positive -> q
 
 val qpower : q -> z -> q
 
-type 'a t0 =
+type 'a t =
 | Empty
 | Leaf of 'a
-| Node of 'a t0 * 'a * 'a t0
+| Node of 'a t * 'a * 'a t
+
+val find : 'a1 -> 'a1 t -> positive -> 'a1
 
-val find : 'a1 -> 'a1 t0 -> positive -> 'a1
+val singleton : 'a1 -> positive -> 'a1 -> 'a1 t
+
+val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t
 
 type zWitness = z psatz
 
@@ -1221,4 +520,3 @@ val runsat : q nFormula -> bool
 val rdeduce : q nFormula -> q nFormula -> q nFormula option
 
 val rTautoChecker : rcst formula bFormula -> rWitness list -> bool
-
diff --git a/plugins/micromega/micromega_plugin.mllib b/plugins/micromega/micromega_plugin.mlpack
index f53a9e37..ed253da3 100644
--- a/plugins/micromega/micromega_plugin.mllib
+++ b/plugins/micromega/micromega_plugin.mlpack
@@ -7,4 +7,3 @@ Certificate
 Persistent_cache
 Coq_micromega
 G_micromega
-Micromega_plugin_mod
diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml
index 2dd443f0..b4c6d032 100644
--- a/plugins/micromega/mutils.ml
+++ b/plugins/micromega/mutils.ml
@@ -66,6 +66,15 @@ let all_sym_pairs f l =
       | e::l -> xpairs (pair_with acc e l) l in
     xpairs [] l
 
+let all_pairs f l = 
+  let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in
+
+  let rec xpairs acc l = 
+    match l with
+      | [] -> acc
+      | e::lx -> xpairs (pair_with acc e l) lx in
+    xpairs [] l
+
 
 
 let rec map3 f l1 l2 l3 =
@@ -285,18 +294,6 @@ struct
   else  XO (index (n lsr 1))
 
 
- let idx n =
-  (*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 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))
-    (List.rev (digits_of_int n))
-    (XH)
-
  let z x =
   match compare x 0 with
    | 0 -> Z0
diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml
index 6a03e2d6..0e6d346a 100644
--- a/plugins/micromega/persistent_cache.ml
+++ b/plugins/micromega/persistent_cache.ml
@@ -92,7 +92,7 @@ let read_key_elem inch =
     Some (Marshal.from_channel inch)
   with
     | End_of_file -> None
-    | e when Errors.noncritical e -> raise InvalidTableFormat
+    | e when CErrors.noncritical e -> raise InvalidTableFormat
 
 (** 
     We used to only lock/unlock regions.
@@ -212,9 +212,11 @@ let find t k =
 	res
 
 let memo cache f =
-  let tbl = lazy (open_in cache) in
-    fun x ->
-      let tbl = Lazy.force tbl in
+  let tbl = lazy (try Some (open_in cache) with _ -> None) in
+  fun x ->
+  match Lazy.force tbl with
+  | None -> f x
+  | Some tbl ->
 	try
 	  find tbl x
 	with
diff --git a/plugins/micromega/vo.itarget b/plugins/micromega/vo.itarget
index bf6a1a7d..c9009ea4 100644
--- a/plugins/micromega/vo.itarget
+++ b/plugins/micromega/vo.itarget
@@ -10,4 +10,6 @@ Tauto.vo
 VarMap.vo
 ZCoeff.vo
 ZMicromega.vo
-Lia.vo
\ No newline at end of file
+Lia.vo
+Lqa.vo
+Lra.vo
diff --git a/plugins/nsatz/Nsatz.v b/plugins/nsatz/Nsatz.v
index 3068b534..b11d15e5 100644
--- a/plugins/nsatz/Nsatz.v
+++ b/plugins/nsatz/Nsatz.v
@@ -298,7 +298,9 @@ Ltac nsatz_call_n info nparam p rr lp kont :=
   match goal with
   | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ =>
     intros _;
+    let lci := fresh "lci" in
     set (lci:=lci0);
+    let lq := fresh "lq" in
     set (lq:=lq0);
     kont c rr lq lci
   end.
@@ -380,10 +382,13 @@ Ltac nsatz_generic radicalmax info lparam lvar :=
     end in 
 
   SplitPolyList ltac:(fun p lp =>
+    let p21 := fresh "p21" in
+    let lp21 := fresh "lp21" in
     set (p21:=p) ;
     set (lp21:=lp);
 (*    idtac "nparam:"; idtac nparam; idtac "p:"; idtac p; idtac "lp:"; idtac lp; *)
     nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci => 
+      let q := fresh "q" in
       set (q := PEmul c (PEpow p21 r)); 
       let Hg := fresh "Hg" in 
       assert (Hg:check lp21 q (lci,lq) = true); 
diff --git a/plugins/nsatz/g_nsatz.ml4 b/plugins/nsatz/g_nsatz.ml4
new file mode 100644
index 00000000..5f906a8d
--- /dev/null
+++ b/plugins/nsatz/g_nsatz.ml4
@@ -0,0 +1,17 @@
+DECLARE PLUGIN "nsatz_plugin"
+
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+DECLARE PLUGIN "nsatz_plugin"
+
+TACTIC EXTEND nsatz_compute
+| [ "nsatz_compute"  constr(lt) ] -> [ Nsatz.nsatz_compute lt ]
+END
diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml
index 482ce505..48bdad82 100644
--- a/plugins/nsatz/ideal.ml
+++ b/plugins/nsatz/ideal.ml
@@ -19,75 +19,6 @@ open Utile
 
 exception NotInIdeal
 
-module type S = sig
-
-(* Monomials *)
-type mon = int array
-
-val mult_mon : mon -> mon -> mon
-val deg : mon -> int
-val compare_mon : mon -> mon -> int
-val div_mon : mon -> mon -> mon
-val div_mon_test : mon -> mon -> bool
-val ppcm_mon : mon -> mon -> mon
-
-(* Polynomials *)
-
-type deg = int
-type coef
-type poly
-type polynom 
-
-val repr : poly -> (coef * mon) list
-val polconst : coef -> poly
-val zeroP : poly
-val gen : int -> poly
-
-val equal : poly -> poly -> bool
-val name_var : string list ref
-val getvar : string list -> int -> string
-val lstringP : poly list -> string
-val printP : poly -> unit
-val lprintP : poly list -> unit
-
-val div_pol_coef : poly -> coef -> poly
-val plusP : poly -> poly -> poly
-val mult_t_pol : coef -> mon -> poly -> poly
-val selectdiv : mon -> poly list -> poly
-val oppP : poly -> poly
-val emultP : coef -> poly -> poly
-val multP : poly -> poly -> poly
-val puisP : poly -> int -> poly
-val contentP : poly -> coef
-val contentPlist : poly list -> coef
-val pgcdpos : coef -> coef -> coef
-val div_pol : poly -> poly -> coef -> coef -> mon -> poly
-val reduce2 : poly -> poly list -> coef * poly
-
-val poldepcontent : coef list ref
-val coefpoldep_find : poly -> poly -> poly
-val coefpoldep_set : poly -> poly -> poly -> unit
-val initcoefpoldep : poly list -> unit
-val reduce2_trace : poly -> poly list -> poly list -> poly list * poly
-val spol : poly -> poly -> poly
-val etrangers : poly -> poly -> bool
-val div_ppcm : poly -> poly -> poly -> bool
-
-val genPcPf : poly -> poly list -> poly list -> poly list
-val genOCPf : poly list -> poly list
-
-val is_homogeneous : poly -> bool
-
-type certificate =
-    { coef : coef; power : int;
-      gb_comb : poly list list; last_comb : poly list }
-
-val test_dans_ideal : poly -> poly list -> poly list ->
-  poly list * poly * certificate
-val in_ideal : deg -> poly list -> poly -> poly list * poly * certificate
-
-end
-
 (***********************************************************************
    Global options
 *)
@@ -127,11 +58,11 @@ type polynom =
     num : int;
     sugar : int}
 
-let nvar m =  Array.length m - 1
+let nvar (m : mon) =  Array.length m - 1
 
-let deg m = m.(0)
+let deg (m : mon) = m.(0)
 
-let mult_mon m m' =
+let mult_mon (m : mon) (m' : mon) =
   let d = nvar m in
   let m'' = Array.make (d+1) 0 in
   for i=0 to d do
@@ -140,7 +71,7 @@ let mult_mon m m' =
   m''
 
 
-let compare_mon m m' =
+let compare_mon (m : mon) (m' : mon) =
   let d = nvar m in
   if !lexico
   then (
@@ -148,18 +79,18 @@ let compare_mon m m' =
     let res=ref 0 in
     let i=ref 1 in (* 1 si lexico pur 0 si degre*)
     while (!res=0) && (!i<=d) do
-      res:= (compare m.(!i) m'.(!i));
+      res:= (Int.compare m.(!i) m'.(!i));
       i:=!i+1;
     done;
     !res)
   else (
      (* degre lexicographique inverse *)
-    match compare m.(0) m'.(0) with
+    match Int.compare m.(0) m'.(0) with
     | 0 -> (* meme degre total *)
 	let res=ref 0 in
 	let i=ref d in
 	while (!res=0) && (!i>=1) do
-	  res:= - (compare m.(!i) m'.(!i));
+	  res:= - (Int.compare m.(!i) m'.(!i));
 	  i:=!i-1;
 	done;
 	!res
@@ -402,29 +333,25 @@ let polconst d c =
   [(c,m)]
 
 let plusP p q =
-  let rec plusP p q =
-    match p with
-      [] -> q
-    |t::p' -> 
-	match q with
-	  [] -> p
-	|t'::q' ->
-            match compare_mon (snd t) (snd t') with
-              1 -> t::(plusP p' q)
-            |(-1) -> t'::(plusP p q')
-            |_ -> let c=P.plusP (fst t) (fst t') in
-              match P.equal c coef0 with
-                true -> (plusP p' q')
-              |false -> (c,(snd t))::(plusP p' q')
-  in plusP p q
+  let rec plusP p q accu = match p, q with
+  | [], [] -> List.rev accu
+  | [], _ -> List.rev_append accu q
+  | _, [] -> List.rev_append accu p
+  | t :: p', t' :: q' ->
+    let c = compare_mon (snd t) (snd t') in
+    if c > 0 then plusP p' q (t :: accu)
+    else if c < 0 then plusP p q' (t' :: accu)
+    else
+      let c = P.plusP (fst t) (fst t') in
+      if P.equal c coef0 then plusP p' q' accu
+      else plusP p' q' ((c, (snd t)) :: accu)
+  in
+  plusP p q []
 
 (* multiplication by (a,monomial) *)
 let mult_t_pol a m p =
-  let rec mult_t_pol p =
-    match p with
-      [] -> []
-    |(b,m')::p -> ((P.multP a b),(mult_mon m m'))::(mult_t_pol p)
-  in mult_t_pol p
+  let map (b, m') = (P.multP a b, mult_mon m m') in
+  CList.map map p
 
 let coef_of_int x = P.of_num (Num.Int x)
 
@@ -451,23 +378,27 @@ let emultP a p =
   in emultP p
 
 let multP p q =
-  let rec aux p =
+  let rec aux p accu =
     match p with
-      [] -> []
-    |(a,m)::p' -> plusP (mult_t_pol a m q) (aux p')
-  in aux p
+      [] -> accu
+    |(a,m)::p' -> aux p' (plusP (mult_t_pol a m q) accu)
+  in aux p []
 
 let puisP p n=
   match p with
     [] -> []
   |_ ->
+    if n = 0 then
       let d = nvar (snd (List.hd p)) in
-      let rec puisP n =
-	match n with
-	  0 -> [coef1, Array.make (d+1) 0]
-	| 1 -> p
-	|_ -> multP p (puisP (n-1))
-      in puisP n
+      [coef1, Array.make (d+1) 0]
+    else
+      let rec puisP p n =
+        if n = 1 then p
+        else
+          let q = puisP p (n / 2) in
+          let q = multP q q in
+          if n mod 2 = 0 then q else multP p q
+      in puisP p n
 	
 let rec contentP p =
   match p with
diff --git a/plugins/nsatz/ideal.mli b/plugins/nsatz/ideal.mli
new file mode 100644
index 00000000..d1a2a0a7
--- /dev/null
+++ b/plugins/nsatz/ideal.mli
@@ -0,0 +1,47 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+module Make (P : Polynom.S) :
+sig
+(* Polynomials *)
+
+type deg = int
+type coef = P.t
+type poly
+
+val repr : poly -> (coef * int array) list
+val polconst : int -> coef -> poly
+val zeroP : poly
+val gen : int -> int -> poly
+
+val equal : poly -> poly -> bool
+val name_var : string list ref
+
+val plusP : poly -> poly -> poly
+val oppP : poly -> poly
+val multP : poly -> poly -> poly
+val puisP : poly -> int -> poly
+
+val poldepcontent : coef list ref
+
+type certificate =
+    { coef : coef; power : int;
+      gb_comb : poly list list; last_comb : poly list }
+
+val in_ideal : deg -> poly list -> poly -> poly list * poly * certificate
+
+module Hashpol : Hashtbl.S with type key = poly
+
+val sugar_flag : bool ref
+val divide_rem_with_critical_pair : bool ref
+
+end
+
+exception NotInIdeal
+
+val lexico : bool ref
diff --git a/plugins/nsatz/nsatz.ml4 b/plugins/nsatz/nsatz.ml
index ced53d82..36bce780 100644
--- a/plugins/nsatz/nsatz.ml4
+++ b/plugins/nsatz/nsatz.ml
@@ -6,9 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "grammar/grammar.cma" i*)
-
-open Errors
+open CErrors
 open Util
 open Term
 open Tactics
@@ -17,8 +15,6 @@ open Coqlib
 open Num
 open Utile
 
-DECLARE PLUGIN "nsatz_plugin"
-
 (***********************************************************************
  Operations on coefficients
 *)
@@ -472,6 +468,44 @@ let theoremedeszeros lpol p =
 
 open Ideal
 
+(* Remove zero polynomials and duplicates from the list of polynomials lp
+   Return (clp, lb)
+   where clp is the reduced list and lb is a list of booleans
+   that has the same size than lp and where true indicates an
+   element that has been removed
+ *)
+let rec clean_pol lp =
+  let t = Hashpol.create 12 in
+  let find p = try Hashpol.find t p 
+               with 
+                 Not_found -> Hashpol.add t p true; false in
+  let rec aux lp =
+    match lp with
+    | [] -> [], []
+    | p :: lp1 -> 
+      let clp, lb = aux lp1 in
+      if equal p zeroP ||  find p then clp, true::lb 
+       else
+        (p :: clp, false::lb) in
+     aux lp
+
+(* Expand the list of polynomials lp putting zeros where the list of 
+   booleans lb indicates there is a missing element 
+   Warning:
+   the expansion is relative to the end of the list in reversed order
+   lp cannot have less elements than lb
+*)
+let expand_pol lb lp =
+ let rec aux lb lp = 
+   match lb with
+   | [] -> lp
+   | true :: lb1 ->  zeroP :: aux lb1 lp
+   | false :: lb1 ->
+     match lp with
+     [] -> assert false
+     | p :: lp1 -> p :: aux lb1 lp1 
+  in List.rev (aux lb (List.rev lp))
+
 let theoremedeszeros_termes lp =
   nvars:=0;(* mise a jour par term_pol_sparse *)
   List.iter set_nvars_term  lp;
@@ -522,20 +556,29 @@ let theoremedeszeros_termes lp =
       | [] -> assert false
       | p::lp1 ->
 	  let lpol = List.rev lp1 in
+          (* preprocessing :
+             we remove zero polynomials and duplicate that are not handled by in_ideal
+             lb is kept in order to fix the certificate in the post-processing 
+          *)
+	  let lpol, lb  = clean_pol lpol in
 	  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 -> equal x zeroP) lc with
 	  | [] -> assert false
 	  | (lq::lci) ->
+              (* post-processing : we apply the correction for the last line *)
+              let lq = expand_pol lb lq in
 	      (* lci commence par les nouveaux polynomes *)
-	      let m= !nvars in
+	      let m = !nvars in
 	      let c = pol_sparse_to_term m (polconst m cert.coef) in
 	      let r = Pow(Zero,cert.power) in
 	      let lci = List.rev lci in
+              (* post-processing we apply the correction for the other lines *)
+	      let lci = List.map (expand_pol lb) lci in
 	      let lci = List.map (List.map (pol_sparse_to_term m)) lci in
 	      let lq = List.map (pol_sparse_to_term m) lq in
-	      info ("number of parametres: "^string_of_int nparam^"\n");
+	      info ("number of parameters: "^string_of_int nparam^"\n");
 	      info "term computed\n";
 	      (c,r,lci,lq)
       )
@@ -591,8 +634,4 @@ let nsatz_compute t =
       error "nsatz cannot solve this problem" in
   return_term lpol
 
-TACTIC EXTEND nsatz_compute
-| [ "nsatz_compute"  constr(lt) ] -> [ Proofview.V82.tactic (nsatz_compute lt) ]
-END
-
 
diff --git a/tools/compat5b.ml b/plugins/nsatz/nsatz.mli
index 37cb487c..e876ccfa 100644
--- a/tools/compat5b.ml
+++ b/plugins/nsatz/nsatz.mli
@@ -6,8 +6,4 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* This file is meant for camlp5, for which there is nothing to
-   add to gain camlp5 compatibility :-).
-
-   See [compat5b.mlp] for the [camlp4] counterpart
-*)
+val nsatz_compute : Constr.t -> unit Proofview.tactic
diff --git a/plugins/nsatz/nsatz_plugin.mllib b/plugins/nsatz/nsatz_plugin.mlpack
index a25e649d..b55adf43 100644
--- a/plugins/nsatz/nsatz_plugin.mllib
+++ b/plugins/nsatz/nsatz_plugin.mlpack
@@ -2,4 +2,4 @@ Utile
 Polynom
 Ideal
 Nsatz
-Nsatz_plugin_mod
+G_nsatz
diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml
index 8e2fc07c..92243246 100644
--- a/plugins/nsatz/utile.ml
+++ b/plugins/nsatz/utile.ml
@@ -51,7 +51,7 @@ let facteurs_liste div constant lp =
                                    if not (constant r)
 				   then l1:=r::(!l1)
                                    else p_dans_lmin:=true)
-			      with e when Errors.noncritical e -> ())
+			      with e when CErrors.noncritical e -> ())
                      lmin;
           if !p_dans_lmin
           then factor lmin lp1
@@ -62,7 +62,7 @@ let facteurs_liste div constant lp =
                 List.iter (fun q -> try (let r = div q p in
 					 if not (constant r)
 					 then l1:=r::(!l1))
-				    with e when Errors.noncritical e ->
+				    with e when CErrors.noncritical e ->
                                       lmin1:=q::(!lmin1))
                           lmin;
 	        factor (List.rev (p::(!lmin1))) !l1)
@@ -93,7 +93,7 @@ let factorise_tableau div zero c f l1 =
       	                       li:=j::(!li);
                                r:=rr;
 			   done)
-                      with e when Errors.noncritical e -> ())
+                      with e when CErrors.noncritical e -> ())
                   l1;
       res.(i)<-(!r,!li))
      f;
diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml
index 8a2a957c..d625e307 100644
--- a/plugins/omega/coq_omega.ml
+++ b/plugins/omega/coq_omega.ml
@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
@@ -27,6 +27,8 @@ open Globnames
 open Nametab
 open Contradiction
 open Misctypes
+open Proofview.Notations
+open Context.Named.Declaration
 
 module OmegaSolver = Omega.MakeOmegaSolver (Bigint)
 open OmegaSolver
@@ -34,9 +36,9 @@ open OmegaSolver
 (* Added by JCF, 09/03/98 *)
 
 let elim_id id =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
     simplest_elim (Tacmach.New.pf_global id gl)
-  end
+  end }
 let resolve_id id gl = Proofview.V82.of_tactic (apply (pf_global gl id)) gl
 
 let timing timer_name f arg = f arg
@@ -148,7 +150,7 @@ let exists_tac c = constructor_tac false (Some 1) 1 (ImplicitBindings [c])
 
 let generalize_tac t = generalize t
 let elim t = simplest_elim t
-let exact t = Tactics.refine t
+let exact t = Tacmach.refine t
 let unfold s = Tactics.unfold_in_concl [Locus.AllOccurrences, Lazy.force s]
 
 let rev_assoc k =
@@ -909,7 +911,7 @@ let rec transform p t =
     try
       let v,th,_ = find_constr t' in
       [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v
-    with e when Errors.noncritical e ->
+    with e when CErrors.noncritical e ->
       let v = new_identifier_var ()
       and th = new_identifier () in
       hide_constr t' v th isnat;
@@ -926,15 +928,15 @@ let rec transform p t =
 	  transform p
 	    (mkApp (Lazy.force coq_Zplus,
 		     [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in
-	unfold sp_Zminus :: tac,t
+	Proofview.V82.of_tactic (unfold sp_Zminus) :: tac,t
     | Kapp(Zsucc,[t1]) ->
 	let tac,t = transform p (mkApp (Lazy.force coq_Zplus,
 					 [| t1; mk_integer one |])) in
-	unfold sp_Zsucc :: tac,t
+	Proofview.V82.of_tactic (unfold sp_Zsucc) :: tac,t
     | Kapp(Zpred,[t1]) ->
 	let tac,t = transform p (mkApp (Lazy.force coq_Zplus,
 					 [| t1; mk_integer negone |])) in
-	unfold sp_Zpred :: tac,t
+	Proofview.V82.of_tactic (unfold sp_Zpred) :: tac,t
    | Kapp(Zmult,[t1;t2]) ->
        let tac1,t1' = transform (P_APP 1 :: p) t1
        and tac2,t2' = transform (P_APP 2 :: p) t2 in
@@ -949,7 +951,7 @@ let rec transform p t =
        end
    | Kapp((Zpos|Zneg|Z0),_) ->
        (try ([],Oz(recognize_number t))
-        with e when Errors.noncritical e -> default false t)
+        with e when CErrors.noncritical e -> default false t)
    | Kvar s -> [],Oatom s
    | Kapp(Zopp,[t]) ->
        let tac,t' = transform (P_APP 1 :: p) t in
@@ -1065,12 +1067,12 @@ let replay_history tactic_normalisation =
 	  let p_initial = [P_APP 1;P_TYPE] in
 	  let tac= shuffle_mult_right p_initial e1.body k e2.body in
 	  Tacticals.New.tclTHENLIST [
-	    Proofview.V82.tactic (generalize_tac
+	    generalize_tac
 	      [mkApp (Lazy.force coq_OMEGA17, [|
 		val_of eq1;
 		val_of eq2;
 		mk_integer k;
-		mkVar id1; mkVar id2 |])]);
+		mkVar id1; mkVar id2 |])];
 	    Proofview.V82.tactic (mk_then tac);
 	    (intros_using [aux]);
 	    Proofview.V82.tactic (resolve_id aux);
@@ -1090,8 +1092,8 @@ let replay_history tactic_normalisation =
 	    in
             Tacticals.New.tclTHENS
 	      (Tacticals.New.tclTHENLIST [
-		Proofview.V82.tactic (unfold sp_Zle);
-		Proofview.V82.tactic (simpl_in_concl);
+		unfold sp_Zle;
+		simpl_in_concl;
 		intro;
 		(absurd not_sup_sup) ])
 	      [ assumption ; reflexivity ]
@@ -1102,7 +1104,7 @@ let replay_history tactic_normalisation =
 		      mkVar (hyp_of_tag e1.id);
 		      mkVar (hyp_of_tag e2.id) |])
 	  in
-	  Proofview.tclTHEN (Proofview.V82.tactic (tclTHEN (generalize_tac [theorem]) (mk_then tac))) (solve_le)
+	  Proofview.tclTHEN (Proofview.V82.tactic (tclTHEN (Proofview.V82.of_tactic (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)
@@ -1117,27 +1119,27 @@ let replay_history tactic_normalisation =
 	    [ Tacticals.New.tclTHENS
 	        (Tacticals.New.tclTHENLIST [
 		  (intros_using [aux]);
-		  Proofview.V82.tactic (generalize_tac
+		  (generalize_tac
 		    [mkApp (Lazy.force coq_OMEGA1,
 		      [| eq1; rhs; mkVar aux; mkVar id |])]);
-		  Proofview.V82.tactic (clear [aux;id]);
+		  (clear [aux;id]);
 		  (intros_using [id]);
 		  (cut (mk_gt kk dd)) ])
 	        [ Tacticals.New.tclTHENS
 		    (cut (mk_gt kk izero))
 		    [ Tacticals.New.tclTHENLIST [
 		        (intros_using [aux1; aux2]);
-		        (Proofview.V82.tactic (generalize_tac
+		        (generalize_tac
 			  [mkApp (Lazy.force coq_Zmult_le_approx,
-			    [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]));
-		        Proofview.V82.tactic (clear [aux1;aux2;id]);
+			    [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]);
+		        (clear [aux1;aux2;id]);
 		        (intros_using [id]);
 		        (loop l) ];
 		      Tacticals.New.tclTHENLIST [
-			(Proofview.V82.tactic (unfold sp_Zgt));
-			(Proofview.V82.tactic simpl_in_concl);
+			(unfold sp_Zgt);
+			simpl_in_concl;
 			reflexivity ] ];
-		  Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (unfold sp_Zgt); Proofview.V82.tactic simpl_in_concl; reflexivity ]
+		  Tacticals.New.tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ]
                 ];
 	      Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ]
 
@@ -1155,22 +1157,22 @@ let replay_history tactic_normalisation =
 	    [ Tacticals.New.tclTHENS (cut (mk_gt kk dd))
 		[Tacticals.New.tclTHENLIST [
 		  (intros_using [aux2;aux1]);
-		  Proofview.V82.tactic (generalize_tac
+		  (generalize_tac
 		    [mkApp (Lazy.force coq_OMEGA4,
                       [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]);
-		  Proofview.V82.tactic (clear [aux1;aux2]);
-		  Proofview.V82.tactic (unfold sp_not);
+		  (clear [aux1;aux2]);
+		  unfold sp_not;
 		  (intros_using [aux]);
 		  Proofview.V82.tactic (resolve_id aux);
 		  Proofview.V82.tactic (mk_then tac);
 		  assumption ] ;
 		 Tacticals.New.tclTHENLIST [
-		   Proofview.V82.tactic (unfold sp_Zgt);
-		   Proofview.V82.tactic simpl_in_concl;
+		   unfold sp_Zgt;
+		   simpl_in_concl;
 		   reflexivity ] ];
               Tacticals.New.tclTHENLIST [
-		Proofview.V82.tactic (unfold sp_Zgt);
-                Proofview.V82.tactic simpl_in_concl;
+		unfold sp_Zgt;
+                simpl_in_concl;
 		reflexivity ] ]
       | EXACT_DIVIDE (e1,k) :: l ->
 	  let id = hyp_of_tag e1.id in
@@ -1185,10 +1187,10 @@ let replay_history tactic_normalisation =
 	      (cut state_eq)
 	      [Tacticals.New.tclTHENLIST [
 		(intros_using [aux1]);
-		Proofview.V82.tactic (generalize_tac
+		(generalize_tac
 		  [mkApp (Lazy.force coq_OMEGA18,
                     [| eq1;eq2;kk;mkVar aux1; mkVar id |])]);
-		Proofview.V82.tactic (clear [aux1;id]);
+		(clear [aux1;id]);
 		(intros_using [id]);
 		(loop l) ];
 	       Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ]
@@ -1200,15 +1202,15 @@ let replay_history tactic_normalisation =
 		 (cut (mk_gt kk izero))
 		 [Tacticals.New.tclTHENLIST [
 		   (intros_using [aux2;aux1]);
-		   Proofview.V82.tactic (generalize_tac
+		   (generalize_tac
 		     [mkApp (Lazy.force coq_OMEGA3,
 		       [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]);
-		   Proofview.V82.tactic (clear [aux1;aux2;id]);
+		   (clear [aux1;aux2;id]);
 		   (intros_using [id]);
 		   (loop l) ];
 		  Tacticals.New.tclTHENLIST [
-		    Proofview.V82.tactic (unfold sp_Zgt);
-                    Proofview.V82.tactic simpl_in_concl;
+		    unfold sp_Zgt;
+                    simpl_in_concl;
 		    reflexivity ] ];
 		Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ]
       | (MERGE_EQ(e3,e1,e2)) :: l ->
@@ -1227,9 +1229,9 @@ let replay_history tactic_normalisation =
 	    (cut (mk_eq eq1 (mk_inv eq2)))
 	    [Tacticals.New.tclTHENLIST [
 	      (intros_using [aux]);
-	      Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_OMEGA8,
+	      (generalize_tac [mkApp (Lazy.force coq_OMEGA8,
 	        [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]);
-	      Proofview.V82.tactic (clear [id1;id2;aux]);
+	      (clear [id1;id2;aux]);
 	      (intros_using [id]);
 	      (loop l) ];
             Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity]
@@ -1261,13 +1263,13 @@ let replay_history tactic_normalisation =
 	    [Tacticals.New.tclTHENLIST [
 	      (intros_using [aux]);
 	      (elim_id aux);
-	      Proofview.V82.tactic (clear [aux]);
+	      (clear [aux]);
 	      (intros_using [vid; aux]);
-	      Proofview.V82.tactic (generalize_tac
+	      (generalize_tac
 		[mkApp (Lazy.force coq_OMEGA9,
 		  [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]);
 	      Proofview.V82.tactic (mk_then tac);
-	      Proofview.V82.tactic (clear [aux]);
+	      (clear [aux]);
 	      (intros_using [id]);
 	      (loop l) ];
             Tacticals.New.tclTHEN (exists_tac eq1) reflexivity ]
@@ -1302,7 +1304,7 @@ let replay_history tactic_normalisation =
               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
             Tacticals.New.tclTHENLIST [
-	      Proofview.V82.tactic (generalize_tac
+	      (generalize_tac
                 [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]);
 	      Proofview.V82.tactic (mk_then tac);
 	      (intros_using [id]);
@@ -1318,33 +1320,33 @@ let replay_history tactic_normalisation =
 		 (cut (mk_gt kk2 izero))
 		 [Tacticals.New.tclTHENLIST [
 		   (intros_using [aux2;aux1]);
-		   Proofview.V82.tactic (generalize_tac
+		   (generalize_tac
 		     [mkApp (Lazy.force coq_OMEGA7, [|
 		       eq1;eq2;kk1;kk2;
 		       mkVar aux1;mkVar aux2;
 		       mkVar id1;mkVar id2 |])]);
-		   Proofview.V82.tactic (clear [aux1;aux2]);
+		   (clear [aux1;aux2]);
 		   Proofview.V82.tactic (mk_then tac);
 		   (intros_using [id]);
 		   (loop l) ];
 		 Tacticals.New.tclTHENLIST [
-		   Proofview.V82.tactic (unfold sp_Zgt);
-                   Proofview.V82.tactic simpl_in_concl;
+		   unfold sp_Zgt;
+                   simpl_in_concl;
 		   reflexivity ] ];
 	      Tacticals.New.tclTHENLIST [
-		Proofview.V82.tactic (unfold sp_Zgt);
-                Proofview.V82.tactic simpl_in_concl;
+		unfold sp_Zgt;
+                simpl_in_concl;
 		reflexivity ] ]
       | CONSTANT_NOT_NUL(e,k) :: l ->
-	  Tacticals.New.tclTHEN (Proofview.V82.tactic (generalize_tac [mkVar (hyp_of_tag e)])) Equality.discrConcl
+	  Tacticals.New.tclTHEN ((generalize_tac [mkVar (hyp_of_tag e)])) Equality.discrConcl
       | CONSTANT_NUL(e) :: l ->
 	  Tacticals.New.tclTHEN (Proofview.V82.tactic (resolve_id (hyp_of_tag e))) reflexivity
       | CONSTANT_NEG(e,k) :: l ->
 	  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);
+	    (generalize_tac [mkVar (hyp_of_tag e)]);
+            unfold sp_Zle;
+	    simpl_in_concl;
+	    unfold sp_not;
 	    (intros_using [aux]);
 	    Proofview.V82.tactic (resolve_id aux);
 	    reflexivity
@@ -1364,8 +1366,8 @@ let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) =
   let (tac,t') = normalize p_initial t in
   let shift_left =
     tclTHEN
-      (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ])
-      (tclTRY (clear [id]))
+      (Proofview.V82.of_tactic (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ]))
+      (tclTRY (Proofview.V82.of_tactic (clear [id])))
   in
   if not (List.is_empty tac) then
     let id' = new_identifier () in
@@ -1410,13 +1412,13 @@ let destructure_omega gl tac_def (id,c) =
 
 let reintroduce id =
   (* [id] cannot be cleared if dependent: protect it by a try *)
-  Tacticals.New.tclTHEN (Proofview.V82.tactic (tclTRY (clear [id]))) (intro_using id)
+  Tacticals.New.tclTHEN (Tacticals.New.tclTRY (clear [id])) (intro_using id)
 
 
 open Proofview.Notations
 
 let coq_omega =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { 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
@@ -1433,7 +1435,7 @@ let coq_omega =
 	     (simplest_elim (applist (Lazy.force coq_intro_Z, [t])));
 	     (intros_using [v; id]);
 	     (elim_id id);
-	     Proofview.V82.tactic (clear [id]);
+	     (clear [id]);
 	     (intros_using [th;id]);
 	     tac ]),
            {kind = INEQ;
@@ -1464,12 +1466,12 @@ let coq_omega =
       Tacticals.New.tclTHEN prelude (replay_history tactic_normalisation path)
     with NO_CONTRADICTION -> Tacticals.New.tclZEROMSG (Pp.str"Omega can't solve this system")
   end
-  end
+  end }
 
 let coq_omega = coq_omega
 
 let nat_inject =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { 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
@@ -1544,7 +1546,7 @@ let nat_inject =
 	  begin try match destructurate_prop t with
               Kapp(Le,[t1;t2]) ->
 		Tacticals.New.tclTHENLIST [
-		  Proofview.V82.tactic (generalize_tac
+		  (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);
@@ -1553,7 +1555,7 @@ let nat_inject =
                 ]
             | Kapp(Lt,[t1;t2]) ->
 		Tacticals.New.tclTHENLIST [
-		  Proofview.V82.tactic (generalize_tac
+		  (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);
@@ -1562,7 +1564,7 @@ let nat_inject =
                 ]
             | Kapp(Ge,[t1;t2]) ->
 		Tacticals.New.tclTHENLIST [
-		  Proofview.V82.tactic (generalize_tac
+		  (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);
@@ -1571,7 +1573,7 @@ let nat_inject =
                 ]
             | Kapp(Gt,[t1;t2]) ->
 		Tacticals.New.tclTHENLIST [
-		  Proofview.V82.tactic (generalize_tac
+		  (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);
@@ -1580,7 +1582,7 @@ let nat_inject =
                 ]
             | Kapp(Neq,[t1;t2]) ->
 		Tacticals.New.tclTHENLIST [
-		  Proofview.V82.tactic (generalize_tac
+		  (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);
@@ -1590,7 +1592,7 @@ let nat_inject =
             | Kapp(Eq,[typ;t1;t2]) ->
 		if is_conv typ (Lazy.force coq_nat) then
                   Tacticals.New.tclTHENLIST [
-		    Proofview.V82.tactic (generalize_tac
+		    (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);
@@ -1603,7 +1605,7 @@ let nat_inject =
   in
   let hyps_types = Tacmach.New.pf_hyps_types gl in
   loop (List.rev hyps_types)
-  end
+  end }
 
 let dec_binop = function
   | Zne -> coq_dec_Zne
@@ -1672,47 +1674,48 @@ let onClearedName id tac =
   (* We cannot ensure that hyps can be cleared (because of dependencies), *)
   (* so renaming may be necessary *)
   Tacticals.New.tclTHEN
-    (Proofview.V82.tactic (tclTRY (clear [id])))
-    (Proofview.Goal.nf_enter begin fun gl ->
+    (Tacticals.New.tclTRY (clear [id]))
+    (Proofview.Goal.nf_enter { enter = begin fun gl ->
      let id = Tacmach.New.of_old (fresh_id [] id) gl in
      Tacticals.New.tclTHEN (introduction id) (tac id)
-    end)
+    end })
 
 let onClearedName2 id tac =
   Tacticals.New.tclTHEN
-    (Proofview.V82.tactic (tclTRY (clear [id])))
-    (Proofview.Goal.nf_enter begin fun gl ->
+    (Tacticals.New.tclTRY (clear [id]))
+    (Proofview.Goal.nf_enter { 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)
+    end })
 
 let destructure_hyps =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let type_of = Tacmach.New.pf_unsafe_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 ->
+      | decl::lit ->
+          let (i,_,t) = to_tuple decl in
 	  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]) ->
               (Tacticals.New.tclTHENS
                  (elim_id i)
-                 [ onClearedName i (fun i -> (loop ((i,None,t1)::lit)));
-                   onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ])
+                 [ onClearedName i (fun i -> (loop (LocalAssum (i,t1)::lit)));
+                   onClearedName i (fun i -> (loop (LocalAssum (i,t2)::lit))) ])
           | Kapp(And,[t1;t2]) ->
               Tacticals.New.tclTHEN
 		(elim_id i)
 		(onClearedName2 i (fun i1 i2 ->
-		  loop ((i1,None,t1)::(i2,None,t2)::lit)))
+		  loop (LocalAssum (i1,t1) :: LocalAssum (i2,t2) :: lit)))
           | Kapp(Iff,[t1;t2]) ->
 	      Tacticals.New.tclTHEN
 		(elim_id i)
 		(onClearedName2 i (fun i1 i2 ->
-		  loop ((i1,None,mkArrow t1 t2)::(i2,None,mkArrow t2 t1)::lit)))
+		  loop (LocalAssum (i1,mkArrow t1 t2) :: LocalAssum (i2,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. *)
@@ -1720,10 +1723,10 @@ let destructure_hyps =
               then
 		let d1 = decidability t1 in
 		Tacticals.New.tclTHENLIST [
-		  Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_imp_simp,
+		  (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))))
+		    (loop (LocalAssum (i,mk_or (mk_not t1) t2) :: lit))))
                 ]
               else
 		loop lit
@@ -1731,55 +1734,54 @@ let destructure_hyps =
               begin match destructurate_prop t with
 		Kapp(Or,[t1;t2]) ->
                   Tacticals.New.tclTHENLIST [
-		    Proofview.V82.tactic (generalize_tac
+		    (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))))
+                      (loop (LocalAssum (i,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
+		    (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))))
+                      (loop (LocalAssum (i,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
+		    (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))))
+                      (loop (LocalAssum (i, 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 t1 in
                   Tacticals.New.tclTHENLIST [
-		    Proofview.V82.tactic (generalize_tac
+		    (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))))
+                      (loop (LocalAssum (i,mk_and t1 (mk_not t2)) :: lit))))
                   ]
 	      | Kapp(Not,[t]) ->
 		  let d = decidability t in
                   Tacticals.New.tclTHENLIST [
-		    Proofview.V82.tactic (generalize_tac
+		    (generalize_tac
 			                    [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]);
-		    (onClearedName i (fun i -> (loop ((i,None,t)::lit))))
+		    (onClearedName i (fun i -> (loop (LocalAssum (i,t) :: lit))))
                   ]
 	      | Kapp(op,[t1;t2]) ->
 		  (try
 		     let thm = not_binop op in
                      Tacticals.New.tclTHENLIST [
-		       Proofview.V82.tactic (generalize_tac
+		       (generalize_tac
 			                       [mkApp (Lazy.force thm, [| t1;t2;mkVar i|])]);
 		       (onClearedName i (fun _ -> loop lit))
                      ]
@@ -1806,15 +1808,13 @@ let destructure_hyps =
 		    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|]))))
+			   (convert_hyp_no_check (set_type (mkApp (Lazy.force coq_neq, [| t1;t2|]))
+                                                           decl))
 			   (loop lit))
 		    | Kapp(Z,_) ->
                         (Tacticals.New.tclTHEN
-			   (convert_hyp_no_check
-                                                    (i,body,
-				                     (mkApp (Lazy.force coq_Zne, [| t1;t2|]))))
+			   (convert_hyp_no_check (set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|]))
+                                                           decl))
 			   (loop lit))
 		    | _ -> loop lit
                   end
@@ -1828,17 +1828,17 @@ let destructure_hyps =
     in
     let hyps = Proofview.Goal.hyps gl in
     loop hyps
-  end
+  end }
 
 let destructure_goal =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { 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]) ->
           (Tacticals.New.tclTHEN
-	     (Tacticals.New.tclTHEN (Proofview.V82.tactic (unfold sp_not)) intro)
+	     (Tacticals.New.tclTHEN (unfold sp_not) intro)
 	     destructure_hyps)
       | Kimp(a,b) -> (Tacticals.New.tclTHEN intro (loop b))
       | Kapp(False,[]) -> destructure_hyps
@@ -1847,7 +1847,7 @@ let destructure_goal =
 	    try
 	      let dec = decidability t in
 	      Tacticals.New.tclTHEN
-                (Proofview.V82.tactic (Tactics.refine
+                (Proofview.V82.tactic (Tacmach.refine
 		                         (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |]))))
 	        intro
 	    with Undecidable -> Tactics.elim_type (build_coq_False ())
@@ -1855,7 +1855,7 @@ let destructure_goal =
 	  Tacticals.New.tclTHEN goal_tac destructure_hyps
     in
     (loop concl)
-  end
+  end }
 
 let destructure_goal = destructure_goal
 
diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4
index c96b4a4f..5647fbf9 100644
--- a/plugins/omega/g_omega.ml4
+++ b/plugins/omega/g_omega.ml4
@@ -17,16 +17,24 @@
 
 DECLARE PLUGIN "omega_plugin"
 
+open Names
 open Coq_omega
+open Constrarg
+
+let eval_tactic name =
+  let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in
+  let kn = KerName.make2 (MPfile dp) (Label.make name) in
+  let tac = Tacenv.interp_ltac kn in
+  Tacinterp.eval_tactic tac
 
 let omega_tactic l =
   let tacs = List.map
     (function
-       | "nat" -> Tacinterp.interp <:tactic<zify_nat>>
-       | "positive" -> Tacinterp.interp <:tactic<zify_positive>>
-       | "N" -> Tacinterp.interp <:tactic<zify_N>>
-       | "Z" -> Tacinterp.interp <:tactic<zify_op>>
-       | s -> Errors.error ("No Omega knowledge base for type "^s))
+       | "nat" -> eval_tactic "zify_nat"
+       | "positive" -> eval_tactic "zify_positive"
+       | "N" -> eval_tactic "zify_N"
+       | "Z" -> eval_tactic "zify_op"
+       | s -> CErrors.error ("No Omega knowledge base for type "^s))
     (Util.List.sort_uniquize String.compare l)
   in
   Tacticals.New.tclTHEN
diff --git a/plugins/omega/omega_plugin.mllib b/plugins/omega/omega_plugin.mlpack
index 2b387fdc..df7f1047 100644
--- a/plugins/omega/omega_plugin.mllib
+++ b/plugins/omega/omega_plugin.mlpack
@@ -1,4 +1,3 @@
 Omega
 Coq_omega
 G_omega
-Omega_plugin_mod
diff --git a/plugins/plugins.itarget b/plugins/plugins.itarget
deleted file mode 100644
index 56aa42b0..00000000
--- a/plugins/plugins.itarget
+++ /dev/null
@@ -1,3 +0,0 @@
-pluginsopt.otarget
-pluginsbyte.otarget
-pluginsvo.otarget
\ No newline at end of file
diff --git a/plugins/pluginsbyte.itarget b/plugins/pluginsbyte.itarget
deleted file mode 100644
index d8752f8b..00000000
--- a/plugins/pluginsbyte.itarget
+++ /dev/null
@@ -1,21 +0,0 @@
-btauto/btauto_plugin.cma
-setoid_ring/newring_plugin.cma
-extraction/extraction_plugin.cma
-decl_mode/decl_mode_plugin.cma
-firstorder/ground_plugin.cma
-rtauto/rtauto_plugin.cma
-fourier/fourier_plugin.cma
-romega/romega_plugin.cma
-omega/omega_plugin.cma
-micromega/micromega_plugin.cma
-cc/cc_plugin.cma
-nsatz/nsatz_plugin.cma
-funind/recdef_plugin.cma
-syntax/ascii_syntax_plugin.cma
-syntax/nat_syntax_plugin.cma
-syntax/numbers_syntax_plugin.cma
-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
deleted file mode 100644
index 220e5182..00000000
--- a/plugins/pluginsdyn.itarget
+++ /dev/null
@@ -1,24 +0,0 @@
-btauto/btauto_plugin.cmxs
-field/field_plugin.cmxs
-setoid_ring/newring_plugin.cmxs
-extraction/extraction_plugin.cmxs
-decl_mode/decl_mode_plugin.cmxs
-firstorder/ground_plugin.cmxs
-rtauto/rtauto_plugin.cmxs
-fourier/fourier_plugin.cmxs
-romega/romega_plugin.cmxs
-omega/omega_plugin.cmxs
-micromega/micromega_plugin.cmxs
-subtac/subtac_plugin.cmxs
-ring/ring_plugin.cmxs
-cc/cc_plugin.cmxs
-nsatz/nsatz_plugin.cmxs
-funind/recdef_plugin.cmxs
-syntax/ascii_syntax_plugin.cmxs
-syntax/nat_syntax_plugin.cmxs
-syntax/numbers_syntax_plugin.cmxs
-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
deleted file mode 100644
index 04a1e711..00000000
--- a/plugins/pluginsopt.itarget
+++ /dev/null
@@ -1,21 +0,0 @@
-btauto/btauto_plugin.cmxa
-setoid_ring/newring_plugin.cmxa
-extraction/extraction_plugin.cmxa
-decl_mode/decl_mode_plugin.cmxa
-firstorder/ground_plugin.cmxa
-rtauto/rtauto_plugin.cmxa
-fourier/fourier_plugin.cmxa
-romega/romega_plugin.cmxa
-omega/omega_plugin.cmxa
-micromega/micromega_plugin.cmxa
-cc/cc_plugin.cmxa
-nsatz/nsatz_plugin.cmxa
-funind/recdef_plugin.cmxa
-syntax/ascii_syntax_plugin.cmxa
-syntax/nat_syntax_plugin.cmxa
-syntax/numbers_syntax_plugin.cmxa
-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
deleted file mode 100644
index a59bf29c..00000000
--- a/plugins/pluginsvo.itarget
+++ /dev/null
@@ -1,12 +0,0 @@
-btauto/vo.otarget
-fourier/vo.otarget
-funind/vo.otarget
-nsatz/vo.otarget
-micromega/vo.otarget
-omega/vo.otarget
-quote/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/g_quote.ml4 b/plugins/quote/g_quote.ml4
index fdc5c2bb..fd87d5b7 100644
--- a/plugins/quote/g_quote.ml4
+++ b/plugins/quote/g_quote.ml4
@@ -13,19 +13,19 @@ open Misctypes
 open Tacexpr
 open Geninterp
 open Quote
+open Constrarg
 
 DECLARE PLUGIN "quote_plugin"
 
 let loc = Loc.ghost
-let cont = (loc, Id.of_string "cont")
-let x = (loc, Id.of_string "x")
+let cont = Id.of_string "cont"
+let x = Id.of_string "x"
 
-let make_cont (k : glob_tactic_expr) (c : Constr.t) =
+let make_cont (k : Val.t) (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
+  let tac = TacCall (loc, ArgVar (loc, cont), [Reference (ArgVar (loc, x))]) in
+  let ist = { lfun = Id.Map.add cont k (Id.Map.singleton x c); extra = TacStore.empty; } in
+  Tacinterp.eval_tactic_ist ist (TacArg (loc, tac))
 
 TACTIC EXTEND quote
   [ "quote" ident(f) ] -> [ quote f [] ]
diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml
index ff6acf13..b3ea4335 100644
--- a/plugins/quote/quote.ml
+++ b/plugins/quote/quote.ml
@@ -101,7 +101,7 @@
 
 
 (*i*)
-open Errors
+open CErrors
 open Util
 open Names
 open Term
@@ -109,6 +109,7 @@ open Pattern
 open Patternops
 open Constr_matching
 open Tacmach
+open Proofview.Notations
 (*i*)
 
 (*s First, we need to access some Coq constants
@@ -227,7 +228,7 @@ let compute_ivs f cs gl =
         let (args3, body3) = decompose_lam body2 in
         let nargs3 = List.length args3 in
         let env = Proofview.Goal.env gl in
-        let sigma = Proofview.Goal.sigma gl in
+        let sigma = Tacmach.New.project 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 *)
@@ -446,7 +447,7 @@ let quote_terms ivs lc =
   yet. *)
 
 let quote f lid =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { 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
@@ -459,10 +460,10 @@ let quote f lid =
     match ivs.variable_lhs with
     | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast
     | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast
-  end
+  end }
 
 let gen_quote cont c f lid =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { 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
@@ -474,7 +475,7 @@ let gen_quote cont c f lid =
   match ivs.variable_lhs with
     | None -> cont (mkApp (f, [| p |]))
     | Some _ -> cont (mkApp (f, [| vm; p |]))
-  end
+  end }
 
 (*i
 
diff --git a/plugins/quote/quote_plugin.mllib b/plugins/quote/quote_plugin.mllib
deleted file mode 100644
index d1b3ccbe..00000000
--- a/plugins/quote/quote_plugin.mllib
+++ /dev/null
@@ -1,3 +0,0 @@
-Quote
-G_quote
-Quote_plugin_mod
diff --git a/plugins/quote/quote_plugin.mlpack b/plugins/quote/quote_plugin.mlpack
new file mode 100644
index 00000000..2e9be09d
--- /dev/null
+++ b/plugins/quote/quote_plugin.mlpack
@@ -0,0 +1,2 @@
+Quote
+G_quote
diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v
index b84cf254..187601fc 100644
--- a/plugins/romega/ReflOmegaCore.v
+++ b/plugins/romega/ReflOmegaCore.v
@@ -1074,16 +1074,19 @@ Qed.
    avait utilisé le test précédent et fait une elimination dessus. *)
 
 Ltac elim_eq_term t1 t2 :=
+  let Aux := fresh "Aux" in
   pattern (eq_term t1 t2); apply bool_eq_ind; intro Aux;
    [ generalize (eq_term_true t1 t2 Aux); clear Aux
    | generalize (eq_term_false t1 t2 Aux); clear Aux ].
 
 Ltac elim_beq t1 t2 :=
+  let Aux := fresh "Aux" in
   pattern (beq t1 t2); apply bool_eq_ind; intro Aux;
    [ generalize (beq_true t1 t2 Aux); clear Aux
    | generalize (beq_false t1 t2 Aux); clear Aux ].
 
 Ltac elim_bgt t1 t2 :=
+  let Aux := fresh "Aux" in
   pattern (bgt t1 t2); apply bool_eq_ind; intro Aux;
   [ generalize (bgt_true t1 t2 Aux); clear Aux
   | generalize (bgt_false t1 t2 Aux); clear Aux ].
@@ -1448,27 +1451,27 @@ Ltac loop t :=
   | (Tint ?X1) => loop X1
   (* Eliminations *)
   | match ?X1 with
-    | EqTerm x x0 => _
-    | LeqTerm x x0 => _
+    | EqTerm _ _ => _
+    | LeqTerm _ _ => _
     | TrueTerm => _
     | FalseTerm => _
-    | Tnot x => _
-    | GeqTerm x x0 => _
-    | GtTerm x x0 => _
-    | LtTerm x x0 => _
-    | NeqTerm x x0 => _
-    | Tor x x0 => _
-    | Tand x x0 => _
-    | Timp x x0 => _
-    | Tprop x => _
+    | Tnot _ => _
+    | GeqTerm _ _ => _
+    | GtTerm _ _ => _
+    | LtTerm _ _ => _
+    | NeqTerm _ _ => _
+    | Tor _ _ => _
+    | Tand _ _ => _
+    | Timp _ _ => _
+    | Tprop _ => _
     end => destruct X1; auto; Simplify
   | match ?X1 with
-    | Tint x => _
-    | (x + x0)%term => _
-    | (x * x0)%term => _
-    | (x - x0)%term => _
-    | (- x)%term => _
-    | [x]%term => _
+    | Tint _ => _
+    | (_ + _)%term => _
+    | (_ * _)%term => _
+    | (_ - _)%term => _
+    | (- _)%term => _
+    | [_]%term => _
     end => destruct X1; auto; Simplify
   | (if beq ?X1 ?X2 then _ else _) =>
       let H := fresh "H" in
@@ -1492,7 +1495,7 @@ with Simplify := match goal with
   end.
 
 Ltac prove_stable x th :=
-  match constr:x with
+  match constr:(x) with
   | ?X1 =>
       unfold term_stable, X1; intros; Simplify; simpl;
        apply th
diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml
index 21b0f78b..4935fe4b 100644
--- a/plugins/romega/const_omega.ml
+++ b/plugins/romega/const_omega.ml
@@ -39,7 +39,7 @@ let destructurate t =
     | Term.Var id,[] -> Kvar(Names.Id.to_string id)
     | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body)
     | Term.Prod (Names.Name _,_,_),[] ->
-	Errors.error "Omega: Not a quantifier-free goal"
+	CErrors.error "Omega: Not a quantifier-free goal"
     | _ -> Kufo
 
 exception Destruct
@@ -346,7 +346,7 @@ let parse_term t =
     | Kapp("Z.succ",[t]) -> Tsucc t
     | Kapp("Z.pred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one))
     | Kapp(("Zpos"|"Zneg"|"Z0"),_) ->
-	(try Tnum (recognize t) with e when Errors.noncritical e -> Tother)
+	(try Tnum (recognize t) with e when CErrors.noncritical e -> Tother)
     | _ -> Tother
   with e when Logic.catchable_exception e -> Tother
 
@@ -368,6 +368,6 @@ let is_scalar t =
     | Kapp(("Z.opp"|"Z.succ"|"Z.pred"),[t]) -> aux t
     | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true
     | _ -> false in
-  try aux t with e when Errors.noncritical e -> false
+  try aux t with e when CErrors.noncritical e -> false
 
 end
diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4
index 0a99a26b..830dc54d 100644
--- a/plugins/romega/g_romega.ml4
+++ b/plugins/romega/g_romega.ml4
@@ -10,16 +10,24 @@
 
 DECLARE PLUGIN "romega_plugin"
 
+open Names
 open Refl_omega
+open Constrarg
+
+let eval_tactic name =
+  let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in
+  let kn = KerName.make2 (MPfile dp) (Label.make name) in
+  let tac = Tacenv.interp_ltac kn in
+  Tacinterp.eval_tactic tac
 
 let romega_tactic l =
   let tacs = List.map
     (function
-       | "nat" -> Tacinterp.interp <:tactic<zify_nat>>
-       | "positive" -> Tacinterp.interp <:tactic<zify_positive>>
-       | "N" -> Tacinterp.interp <:tactic<zify_N>>
-       | "Z" -> Tacinterp.interp <:tactic<zify_op>>
-       | s -> Errors.error ("No ROmega knowledge base for type "^s))
+       | "nat" -> eval_tactic "zify_nat"
+       | "positive" -> eval_tactic "zify_positive"
+       | "N" -> eval_tactic "zify_N"
+       | "Z" -> eval_tactic "zify_op"
+       | s -> CErrors.error ("No ROmega knowledge base for type "^s))
     (Util.List.sort_uniquize String.compare l)
   in
   Tacticals.New.tclTHEN
diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml
index 560e6a89..ba882e39 100644
--- a/plugins/romega/refl_omega.ml
+++ b/plugins/romega/refl_omega.ml
@@ -9,7 +9,7 @@
 open Pp
 open Util
 open Const_omega
-module OmegaSolver = Omega.MakeOmegaSolver (Bigint)
+module OmegaSolver = Omega_plugin.Omega.MakeOmegaSolver (Bigint)
 open OmegaSolver
 
 (* \section{Useful functions and flags} *)
@@ -172,7 +172,7 @@ let print_env_reification env =
   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)
+  Feedback.msg_debug (prop_info ++ fnl () ++ term_info)
 
 (* \subsection{Gestion des environnements de variable pour Omega} *)
 (* generation d'identifiant d'equation pour Omega *)
@@ -454,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) ->
-     Errors.error "Omega: Can't solve a goal with non-linear products"
+     CErrors.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))
@@ -473,7 +473,7 @@ 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) ->
-     Errors.error "Omega: Can't solve a goal with non-linear products"
+     CErrors.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)
@@ -545,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; Errors.error "shrink.1"
+       flush Pervasives.stdout; CErrors.error "shrink.1"
   end
 
 (* \subsection{Calcul d'une sous formule constante} *)
@@ -559,9 +559,9 @@ let reduce_factor = function
       let rec compute = function
           Oint n -> n
 	| Oplus(t1,t2) -> compute t1 + compute t2
-	| _ -> Errors.error "condense.1" in
+	| _ -> CErrors.error "condense.1" in
 	[Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c))
-  | t -> Errors.error "reduce_factor.1"
+  | t -> CErrors.error "reduce_factor.1"
 
 (* \subsection{Réordonnancement} *)
 
@@ -1280,12 +1280,12 @@ let resolution env full_reified_goal systems_list =
     CCHyp{o_hyp=id_concl;o_path=[]} :: hyp_stated_vars @ initial_context in
   let decompose_tactic = decompose_tree env context solution_tree in
 
-  Tactics.generalize
-    (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps)) >>
+  Proofview.V82.of_tactic (Tactics.generalize
+    (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps))) >>
   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 >>
+  Proofview.V82.of_tactic (Tactics.normalise_vm_in_concl) >>
   (*i Alternatives to the previous line:
    - Normalisation without VM:
       Tactics.normalise_in_concl
@@ -1304,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 -> Errors.error "ROmega can't solve this system"
+  with NO_CONTRADICTION -> CErrors.error "ROmega can't solve this system"
 
 
 (*i let tester = Tacmach.hide_atomic_tactic "TestOmega" test_tactic i*)
diff --git a/plugins/romega/romega_plugin.mllib b/plugins/romega/romega_plugin.mlpack
index 1625009d..38d0e941 100644
--- a/plugins/romega/romega_plugin.mllib
+++ b/plugins/romega/romega_plugin.mlpack
@@ -1,4 +1,3 @@
 Const_omega
 Refl_omega
 G_romega
-Romega_plugin_mod
diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v
index 7394cebd..36460187 100644
--- a/plugins/rtauto/Bintree.v
+++ b/plugins/rtauto/Bintree.v
@@ -266,7 +266,7 @@ Qed.
 
 Lemma push_not_empty: forall a S, (push a S) <> empty.
 intros a [ind cont];unfold push,empty.
-simpl;intro H;injection H; intros _ ; apply Pos.succ_not_1.
+intros [= H%Pos.succ_not_1]. assumption.
 Qed.
 
 Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop :=
diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml
index 3ba92b9f..8b926111 100644
--- a/plugins/rtauto/proof_search.ml
+++ b/plugins/rtauto/proof_search.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Goptions
 
@@ -547,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
-    msg_info
+    Feedback.msg_info
       ( str "Proof-search statistics :" ++ fnl () ++
 	count_info ++
 	str "Branch ends: " ++
diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml
index 9c22b5ad..4ed90795 100644
--- a/plugins/rtauto/refl_tauto.ml
+++ b/plugins/rtauto/refl_tauto.ml
@@ -8,11 +8,12 @@
 
 module Search = Explore.Make(Proof_search)
 
-open Errors
+open CErrors
 open Util
 open Term
 open Tacmach
 open Proof_search
+open Context.Named.Declaration
 
 let force count lazc = incr count;Lazy.force lazc
 
@@ -66,12 +67,12 @@ let l_D_Or = lazy (constant "D_Or")
 
 
 let special_whd gl=
-  let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in
-    (fun t -> Closure.whd_val infos (Closure.inject t))
+  let infos=CClosure.create_clos_infos CClosure.all (pf_env gl) in
+    (fun t -> CClosure.whd_val infos (CClosure.inject t))
 
 let special_nf gl=
-  let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in
-    (fun t -> Closure.norm_val infos (Closure.inject t))
+  let infos=CClosure.create_clos_infos CClosure.betaiotazeta (pf_env gl) in
+    (fun t -> CClosure.norm_val infos (CClosure.inject t))
 
 type atom_env=
     {mutable next:int;
@@ -128,9 +129,9 @@ let rec make_form atom_env gls term =
 
 let rec make_hyps atom_env gls lenv = function
     [] -> []
-  | (_,Some body,typ)::rest ->
+  | LocalDef (_,body,typ)::rest ->
       make_hyps atom_env gls (typ::body::lenv) rest
-  | (id,None,typ)::rest ->
+  | LocalAssum (id,typ)::rest ->
       let hrec=
 	make_hyps atom_env gls (typ::lenv) rest in
 	if List.exists (Termops.dependent (mkVar id)) lenv ||
@@ -275,7 +276,7 @@ let rtauto_tac gls=
     begin
       reset_info ();
       if !verbose then
-	msg_info (str "Starting proof-search ...");
+	Feedback.msg_info (str "Starting proof-search ...");
     end in
   let search_start_time = System.get_time () in
   let prf =
@@ -285,10 +286,10 @@ let rtauto_tac gls=
   let search_end_time = System.get_time () in
   let _ = if !verbose then
     begin
-      msg_info (str "Proof tree found in " ++
+      Feedback.msg_info (str "Proof tree found in " ++
 	     System.fmt_time_difference search_start_time search_end_time);
       pp_info ();
-      msg_info (str "Building proof term ... ")
+      Feedback.msg_info (str "Building proof term ... ")
     end in
   let build_start_time=System.get_time () in
   let _ = step_count := 0; node_count := 0 in
@@ -301,7 +302,7 @@ let rtauto_tac gls=
   let build_end_time=System.get_time () in
   let _ = if !verbose then
     begin
-      msg_info (str "Proof term built in " ++
+      Feedback.msg_info (str "Proof term built in " ++
 	     System.fmt_time_difference build_start_time build_end_time ++
 	     fnl () ++
 	     str "Proof size : " ++ int !step_count ++
@@ -315,12 +316,12 @@ let rtauto_tac gls=
     if !check then
       Proofview.V82.of_tactic (Tactics.exact_check term) gls
     else
-      Tactics.exact_no_check term gls in
+      Proofview.V82.of_tactic (Tactics.exact_no_check term) gls in
   let tac_end_time = System.get_time () in
   let _ =
-    if !check then msg_info (str "Proof term type-checking is on");
+    if !check then Feedback.msg_info (str "Proof term type-checking is on");
     if !verbose then
-      msg_info (str "Internal tactic executed in " ++
+      Feedback.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 c9e591bb..9a14ac6c 100644
--- a/plugins/rtauto/refl_tauto.mli
+++ b/plugins/rtauto/refl_tauto.mli
@@ -18,7 +18,7 @@ val make_hyps :
     atom_env ->
     Proof_type.goal Tacmach.sigma ->
     Term.types list ->
-    (Names.Id.t * Term.types option * Term.types) list ->
+    Context.Named.t ->
     (Names.Id.t * Proof_search.form) list
 
 val rtauto_tac : Proof_type.tactic
diff --git a/plugins/rtauto/rtauto_plugin.mllib b/plugins/rtauto/rtauto_plugin.mlpack
index 0e346044..61c5e945 100644
--- a/plugins/rtauto/rtauto_plugin.mllib
+++ b/plugins/rtauto/rtauto_plugin.mlpack
@@ -1,4 +1,3 @@
 Proof_search
 Refl_tauto
 G_rtauto
-Rtauto_plugin_mod
diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v
index 04decbce..5f5b9792 100644
--- a/plugins/setoid_ring/ArithRing.v
+++ b/plugins/setoid_ring/ArithRing.v
@@ -32,13 +32,13 @@ Qed.
 Ltac natcst t :=
   match isnatcst t with
     true => constr:(N.of_nat t)
-  | _ => constr:InitialRing.NotConstant
+  | _ => constr:(InitialRing.NotConstant)
   end.
 
 Ltac Ss_to_add f acc :=
   match f with
   | S ?f1 => Ss_to_add f1 (S acc)
-  | _ => constr:(acc + f)%nat
+  | _ => constr:((acc + f)%nat)
   end.
 
 Ltac natprering :=
diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v
index 8362c8c2..9c690e2b 100644
--- a/plugins/setoid_ring/InitialRing.v
+++ b/plugins/setoid_ring/InitialRing.v
@@ -96,7 +96,7 @@ Section ZMORPHISM.
  Proof.
   constructor.
   destruct c;intros;try discriminate.
-  injection H;clear H;intros H1;subst c'.
+  injection H as <-.
   simpl. unfold Zeq_bool. rewrite Z.compare_refl. trivial.
  Qed.
 
@@ -612,32 +612,32 @@ End GEN_DIV.
  Ltac inv_gen_phi_pos rI add mul t :=
    let rec inv_cst t :=
    match t with
-     rI => constr:1%positive
-   | (add rI rI) => constr:2%positive
-   | (add rI (add rI rI)) => constr:3%positive
+     rI => constr:(1%positive)
+   | (add rI rI) => constr:(2%positive)
+   | (add rI (add rI rI)) => constr:(3%positive)
    | (mul (add rI rI) ?p) => (* 2p *)
        match inv_cst p with
-         NotConstant => constr:NotConstant
-       | 1%positive => constr:NotConstant (* 2*1 is not convertible to 2 *)
+         NotConstant => constr:(NotConstant)
+       | 1%positive => constr:(NotConstant) (* 2*1 is not convertible to 2 *)
        | ?p => constr:(xO p)
        end
    | (add rI (mul (add rI rI) ?p)) => (* 1+2p *)
        match inv_cst p with
-         NotConstant => constr:NotConstant
-       | 1%positive => constr:NotConstant
+         NotConstant => constr:(NotConstant)
+       | 1%positive => constr:(NotConstant)
        | ?p => constr:(xI p)
        end
-   | _ => constr:NotConstant
+   | _ => constr:(NotConstant)
    end in
    inv_cst t.
 
 (* The (partial) inverse of gen_phiNword *)
  Ltac inv_gen_phiNword rO rI add mul opp t :=
    match t with
-     rO => constr:NwO
+     rO => constr:(NwO)
    | _ =>
      match inv_gen_phi_pos rI add mul t with
-       NotConstant => constr:NotConstant
+       NotConstant => constr:(NotConstant)
      | ?p => constr:(Npos p::nil)
      end
    end.
@@ -646,10 +646,10 @@ End GEN_DIV.
 (* The inverse of gen_phiN *)
  Ltac inv_gen_phiN rO rI add mul t :=
    match t with
-     rO => constr:0%N
+     rO => constr:(0%N)
    | _ =>
      match inv_gen_phi_pos rI add mul t with
-       NotConstant => constr:NotConstant
+       NotConstant => constr:(NotConstant)
      | ?p => constr:(Npos p)
      end
    end.
@@ -657,15 +657,15 @@ End GEN_DIV.
 (* The inverse of gen_phiZ *)
  Ltac inv_gen_phiZ rO rI add mul opp t :=
    match t with
-     rO => constr:0%Z
+     rO => constr:(0%Z)
    | (opp ?p) =>
      match inv_gen_phi_pos rI add mul p with
-       NotConstant => constr:NotConstant
+       NotConstant => constr:(NotConstant)
      | ?p => constr:(Zneg p)
      end
    | _ =>
      match inv_gen_phi_pos rI add mul t with
-       NotConstant => constr:NotConstant
+       NotConstant => constr:(NotConstant)
      | ?p => constr:(Zpos p)
      end
    end.
@@ -681,7 +681,7 @@ Ltac inv_gen_phi rO rI cO cI t :=
   end.
 
 (* A simple tactic recognizing no constant *)
- Ltac inv_morph_nothing t := constr:NotConstant.
+ Ltac inv_morph_nothing t := constr:(NotConstant).
 
 Ltac coerce_to_almost_ring set ext rspec :=
   match type of rspec with
@@ -825,31 +825,31 @@ Ltac ring_elements set ext rspec pspec sspec dspec rk :=
 (* Tactic for constant *)
 Ltac isnatcst t :=
   match t with
-    O => constr:true
+    O => constr:(true)
   | S ?p => isnatcst p
-  | _ => constr:false
+  | _ => constr:(false)
   end.
 
 Ltac isPcst t :=
   match t with
   | xI ?p => isPcst p
   | xO ?p => isPcst p
-  | xH => constr:true
+  | xH => constr:(true)
   (* nat -> positive *)
   | Pos.of_succ_nat ?n => isnatcst n
-  | _ => constr:false
+  | _ => constr:(false)
   end.
 
 Ltac isNcst t :=
   match t with
-    N0 => constr:true
+    N0 => constr:(true)
   | Npos ?p => isPcst p
-  | _ => constr:false
+  | _ => constr:(false)
   end.
 
 Ltac isZcst t :=
   match t with
-    Z0 => constr:true
+    Z0 => constr:(true)
   | Zpos ?p => isPcst p
   | Zneg ?p => isPcst p
   (* injection nat -> Z *)
@@ -857,7 +857,7 @@ Ltac isZcst t :=
   (* injection N -> Z *)
   | Z.of_N ?n => isNcst n
   (* *)
-  | _ => constr:false
+  | _ => constr:(false)
   end.
 
 
diff --git a/plugins/setoid_ring/NArithRing.v b/plugins/setoid_ring/NArithRing.v
index 6c1a79e4..54e2789b 100644
--- a/plugins/setoid_ring/NArithRing.v
+++ b/plugins/setoid_ring/NArithRing.v
@@ -15,7 +15,7 @@ Set Implicit Arguments.
 Ltac Ncst t :=
   match isNcst t with
     true => t
-  | _ => constr:NotConstant
+  | _ => constr:(NotConstant)
   end.
 
 Add Ring Nr : Nth (decidable Neqb_ok, constants [Ncst]).
diff --git a/plugins/setoid_ring/Ncring_initial.v b/plugins/setoid_ring/Ncring_initial.v
index 96885d2f..20022c00 100644
--- a/plugins/setoid_ring/Ncring_initial.v
+++ b/plugins/setoid_ring/Ncring_initial.v
@@ -18,7 +18,6 @@ Require Import BinInt.
 Require Import Setoid.
 Require Export Ncring.
 Require Export Ncring_polynom.
-Import List.
 
 Set Implicit Arguments.
 
@@ -78,7 +77,8 @@ Context {R:Type}`{Ring R}.
   | Z0 => 0
   | Zneg p => -(gen_phiPOS p)
   end.
- Notation "[ x ]" := (gen_phiZ x).
+ Local Notation "[ x ]" := (gen_phiZ x) : ZMORPHISM.
+ Local Open Scope ZMORPHISM.
 
  Definition get_signZ z :=
   match z with
diff --git a/plugins/setoid_ring/Ring.v b/plugins/setoid_ring/Ring.v
index a0844100..77576cb9 100644
--- a/plugins/setoid_ring/Ring.v
+++ b/plugins/setoid_ring/Ring.v
@@ -36,9 +36,9 @@ Qed.
 Ltac bool_cst t :=
   let t := eval hnf in t in
   match t with
-    true => constr:true
-  | false => constr:false
-  | _ => constr:NotConstant
+    true => constr:(true)
+  | false => constr:(false)
+  | _ => constr:(NotConstant)
   end.
 
 Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]).
diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v
index 760ad4da..b6919667 100644
--- a/plugins/setoid_ring/Ring_polynom.v
+++ b/plugins/setoid_ring/Ring_polynom.v
@@ -883,7 +883,7 @@ Section MakeRingPol.
  revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros.
  - discriminate.
  - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst.
-   * injection H; intros <-. rewrite <- PSubstL1_ok; intuition.
+   * injection H as <-. rewrite <- PSubstL1_ok; intuition.
    * now apply IH.
  Qed.
 
diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v
index 77863edc..fc02cef1 100644
--- a/plugins/setoid_ring/Ring_tac.v
+++ b/plugins/setoid_ring/Ring_tac.v
@@ -422,8 +422,6 @@ Tactic Notation (at level 0)
   let G := Get_goal in
   ring_lookup (PackRing Ring_simplify) [lH] rl G.
 
-(* MON DIEU QUE C'EST MOCHE !!!!!!!!!!!!! *)
-
 Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):=
   let G := Get_goal in
   let t := type of H in
diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v
index 7fcd6c08..f7757a18 100644
--- a/plugins/setoid_ring/Ring_theory.v
+++ b/plugins/setoid_ring/Ring_theory.v
@@ -238,7 +238,6 @@ Section ALMOST_RING.
  Variable req : R -> R -> Prop.
  Notation "0" := rO.  Notation "1" := rI.
  Infix "==" := req. Infix "+" := radd.  Infix "* " := rmul.
- Infix "-" := rsub. Notation "- x" := (ropp x).
 
  (** Leibniz equality leads to a setoid theory and is extensional*)
  Lemma Eqsth : Equivalence (@eq R).
@@ -263,7 +262,7 @@ Section ALMOST_RING.
         -x = x and x - y = x + y *)
  Definition SRopp (x:R) := x. Notation "- x" := (SRopp x).
 
- Definition SRsub x y := x + -y. Notation "x - y " := (SRsub x y).
+ Definition SRsub x y := x + -y. Infix "-" := SRsub.
 
  Lemma SRopp_ext : forall x y, x == y -> -x == -y.
  Proof. intros x y H; exact H. Qed.
@@ -320,6 +319,8 @@ Section ALMOST_RING.
  Qed.
 
  End  SEMI_RING.
+ Infix "-" := rsub.
+ Notation "- x" := (ropp x).
 
  Variable Reqe : ring_eq_ext radd rmul ropp req.
    Add Morphism radd : radd_ext2.  exact (Radd_ext Reqe). Qed.
diff --git a/plugins/setoid_ring/ZArithRing.v b/plugins/setoid_ring/ZArithRing.v
index 91484372..23784cf3 100644
--- a/plugins/setoid_ring/ZArithRing.v
+++ b/plugins/setoid_ring/ZArithRing.v
@@ -17,14 +17,14 @@ Set Implicit Arguments.
 Ltac Zcst t :=
   match isZcst t with
     true => t
-  | _ => constr:NotConstant
+  | _ => constr:(NotConstant)
   end.
 
 Ltac isZpow_coef t :=
   match t with
   | Zpos ?p => isPcst p
-  | Z0 => constr:true
-  | _ => constr:false
+  | Z0 => constr:(true)
+  | _ => constr:(false)
   end.
 
 Notation N_of_Z := Z.to_N (only parsing).
@@ -32,7 +32,7 @@ Notation N_of_Z := Z.to_N (only parsing).
 Ltac Zpow_tac t :=
  match isZpow_coef t with
  | true => constr:(N_of_Z t)
- | _ => constr:NotConstant
+ | _ => constr:(NotConstant)
  end.
 
 Ltac Zpower_neg :=
diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4
new file mode 100644
index 00000000..216eb8b3
--- /dev/null
+++ b/plugins/setoid_ring/g_newring.ml4
@@ -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        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Pp
+open Util
+open Libnames
+open Printer
+open Newring_ast
+open Newring
+open Stdarg
+open Constrarg
+open Pcoq.Constr
+open Pcoq.Tactic
+
+DECLARE PLUGIN "newring_plugin"
+
+TACTIC EXTEND protect_fv
+  [ "protect_fv" string(map) "in" ident(id) ] ->
+    [ protect_tac_in map id ]
+| [ "protect_fv" string(map) ] ->
+    [ protect_tac map ]
+END
+
+TACTIC EXTEND closed_term
+  [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] ->
+    [ closed_term t l ]
+END
+
+open Pptactic
+open Ppconstr
+
+let pr_ring_mod = function
+  | Ring_kind (Computational eq_test) -> str "decidable" ++ pr_arg pr_constr_expr eq_test
+  | Ring_kind Abstract ->  str "abstract"
+  | Ring_kind (Morphism morph) -> str "morphism" ++ pr_arg pr_constr_expr morph
+  | Const_tac (CstTac cst_tac) -> str "constants" ++ spc () ++ str "[" ++ pr_raw_tactic cst_tac ++ str "]"
+  | Const_tac (Closed l) -> str "closed" ++ spc () ++ str "[" ++ prlist_with_sep spc pr_reference l ++ str "]"
+  | Pre_tac t -> str "preprocess" ++ spc () ++ str "[" ++ pr_raw_tactic t ++ str "]"
+  | Post_tac t -> str "postprocess" ++ spc () ++ str "[" ++ pr_raw_tactic t ++ str "]"
+  | Setoid(sth,ext) -> str "setoid" ++ pr_arg pr_constr_expr sth ++ pr_arg pr_constr_expr ext
+  | Pow_spec(Closed l,spec) -> str "power_tac" ++ pr_arg pr_constr_expr spec ++ spc () ++ str "[" ++ prlist_with_sep spc pr_reference l ++ str "]"
+  | Pow_spec(CstTac cst_tac,spec) -> str "power_tac" ++ pr_arg pr_constr_expr spec ++ spc () ++ str "[" ++ pr_raw_tactic cst_tac ++ str "]"
+  | Sign_spec t -> str "sign" ++ pr_arg pr_constr_expr t
+  | Div_spec t -> str "div" ++ pr_arg pr_constr_expr t
+
+VERNAC ARGUMENT EXTEND ring_mod
+  PRINTED BY pr_ring_mod
+  | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational eq_test) ]
+  | [ "abstract" ] -> [ Ring_kind Abstract ]
+  | [ "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 ]
+  | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ]
+  | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ]
+  | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ]
+  | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] ->
+           [ Pow_spec (Closed l, pow_spec) ]
+  | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] ->
+           [ Pow_spec (CstTac cst_tac, pow_spec) ]
+  | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ]
+END
+
+let pr_ring_mods l = surround (prlist_with_sep pr_comma pr_ring_mod l)
+
+VERNAC ARGUMENT EXTEND ring_mods
+  PRINTED BY pr_ring_mods
+  | [ "(" ne_ring_mod_list_sep(mods, ",") ")" ] -> [ mods ]
+END
+
+VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF
+  | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods_opt(l) ] ->
+    [ let l = match l with None -> [] | Some l -> l in
+      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] -> [
+    Feedback.msg_notice (strbrk "The following ring structures have been declared:");
+    Spmap.iter (fun fn fi ->
+      Feedback.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
+
+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]
+END
+
+let pr_field_mod = function
+  | Ring_mod m -> pr_ring_mod m
+  | Inject inj -> str "completeness" ++ pr_arg pr_constr_expr inj
+
+VERNAC ARGUMENT EXTEND field_mod
+  PRINTED BY pr_field_mod
+  | [ ring_mod(m) ] -> [ Ring_mod m ]
+  | [ "completeness" constr(inj) ] -> [ Inject inj ]
+END
+
+let pr_field_mods l = surround (prlist_with_sep pr_comma pr_field_mod l)
+
+VERNAC ARGUMENT EXTEND field_mods
+  PRINTED BY pr_field_mods
+  | [ "(" ne_field_mod_list_sep(mods, ",") ")" ] -> [ mods ]
+END
+
+VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF
+| [ "Add" "Field" ident(id) ":" constr(t) field_mods_opt(l) ] ->
+  [ let l = match l with None -> [] | Some l -> l in
+    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] -> [
+    Feedback.msg_notice (strbrk "The following field structures have been declared:");
+    Spmap.iter (fun fn fi ->
+      Feedback.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
+
+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 ]
+END
diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml
index e704c466..90f5f8e6 100644
--- a/plugins/setoid_ring/newring.ml4
+++ b/plugins/setoid_ring/newring.ml
@@ -6,15 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "grammar/grammar.cma" i*)
-
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Term
 open Vars
-open Closure
+open CClosure
 open Environ
 open Libnames
 open Globnames
@@ -30,21 +28,12 @@ open Declare
 open Decl_kinds
 open Entries
 open Misctypes
-
-DECLARE PLUGIN "newring_plugin"
+open Newring_ast
+open Proofview.Notations
 
 (****************************************************************************)
 (* controlled reduction *)
 
-(** 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 (Evar.repr i) c
-    | _ -> assert false
-
 type protect_flag = Eval|Prot|Rec
 
 let tag_arg tag_rec map subs i c =
@@ -77,12 +66,10 @@ and mk_clos_app_but f_map subs f args n =
     let fargs, args' = Array.chop n args in
     let f' = mkApp(f,fargs) in
     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'))
-            subs
-            (mkApp (mark_arg (-1) f', Array.mapi mark_arg args'))
-      | None -> mk_clos_app_but f_map subs f args (n+1)
+    | Some map ->
+       let f i t = tag_arg (mk_clos_but f_map subs) map subs i t in
+       mk_red (FApp (f (-1) f', Array.mapi f args'))
+    | None -> mk_atom (mkApp (f, args))
 
 let interp_map l t =
   try Some(List.assoc_f eq_gr t l) with Not_found -> None
@@ -95,36 +82,23 @@ let lookup_map map =
     errorlabstrm"lookup_map"(str"map "++qs map++str"not found")
 
 let protect_red map env sigma c =
-  kl (create_clos_infos betadeltaiota env)
+  kl (create_clos_infos all env)
     (mk_clos_but (lookup_map map c) (Esubst.subs_id 0) c);;
 
 let protect_tac map =
-  Tactics.reduct_option (protect_red map,DEFAULTcast) None ;;
+  Tactics.reduct_option (protect_red map,DEFAULTcast) None
 
 let protect_tac_in map id =
-  Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp));;
-
+  Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp))
 
-TACTIC EXTEND protect_fv
-  [ "protect_fv" string(map) "in" ident(id) ] ->
-    [ Proofview.V82.tactic (protect_tac_in map id) ]
-| [ "protect_fv" string(map) ] ->
-    [ Proofview.V82.tactic (protect_tac map) ]
-END;;
 
 (****************************************************************************)
 
 let closed_term t l =
+  let open Quote_plugin 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) "]" ] ->
-    [ Proofview.V82.tactic (closed_term t l) ]
-END
-;;
+  if Quote.closed_under cs t then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (mt())
 
 (* TACTIC EXTEND echo
 | [ "echo" constr(t) ] ->
@@ -143,11 +117,15 @@ let closed_term_ast l =
     mltac_plugin = "newring_plugin";
     mltac_tactic = "closed_term";
   } in
+  let tacname = {
+    mltac_name = tacname;
+    mltac_index = 0;
+  } 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]))
+  [TacGeneric (Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None));
+   TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l)]))
 (*
 let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term"
 *)
@@ -164,11 +142,6 @@ let ic_unsafe c = (*FIXME remove *)
   let sigma = Evd.from_env env in
     fst (Constrintern.interp_constr env sigma c)
 
-let ty c =
-  let env = Global.env() in
-  let sigma = Evd.from_env env in
-    Typing.unsafe_type_of env sigma c
-
 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
@@ -185,18 +158,16 @@ let ltac_call tac (args:glob_tactic_arg list) =
 let ltac_lcall tac args =
   TacArg(Loc.ghost,TacCall(Loc.ghost, ArgVar(Loc.ghost, Id.of_string tac),args))
 
-let ltac_letin (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)
-
-
-let carg c = TacDynamic(Loc.ghost,Pretyping.constr_in c)
+let ltac_apply (f : Value.t) (args: Tacinterp.Value.t list) =
+  let fold arg (i, vars, lfun) =
+    let id = Id.of_string ("x" ^ string_of_int i) in
+    let x = Reference (ArgVar (Loc.ghost, id)) in
+    (succ i, x :: vars, Id.Map.add id arg lfun)
+  in
+  let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in
+  let lfun = Id.Map.add (Id.of_string "F") f lfun in
+  let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in
+  Tacinterp.eval_tactic_ist ist (ltac_lcall "F" args)
 
 let dummy_goal env sigma =
   let (gl,_,sigma) = 
@@ -207,20 +178,39 @@ let constr_of v = match Value.to_constr v with
   | Some c -> c
   | None -> failwith "Ring.exec_tactic: anomaly"
 
+let tactic_res = ref [||]
+
+let get_res =
+  let open Tacexpr in
+  let name = { mltac_plugin = "newring_plugin"; mltac_tactic = "get_res"; } in
+  let entry = { mltac_name = name; mltac_index = 0 } in
+  let tac args ist =
+    let n = Tacinterp.Value.cast (Genarg.topwit Stdarg.wit_int) (List.hd args) in
+    let init i = Id.Map.find (Id.of_string ("x" ^ string_of_int i)) ist.lfun in
+    tactic_res := Array.init n init;
+    Proofview.tclUNIT ()
+  in
+  Tacenv.register_ml_tactic name [| tac |];
+  entry
+
 let exec_tactic env evd n f args =
+  let fold arg (i, vars, lfun) =
+    let id = Id.of_string ("x" ^ string_of_int i) in
+    let x = Reference (ArgVar (Loc.ghost, id)) in
+    (succ i, x :: vars, Id.Map.add id (Value.of_constr arg) lfun)
+  in
+  let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in
+  let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in
+  (** Build the getter *)
   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 ->  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,
-                  Tacintern.glob_tactic(tacticIn get_res))) in
+  let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in
+  let get_res = TacML (Loc.ghost, get_res, [TacGeneric n]) in
+  let getter = Tacexp (TacFun (List.map (fun id -> Some id) lid, get_res)) in
+  (** Evaluate the whole result *)
   let gl = dummy_goal env evd in
-  let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic(ltac_call f (args@[getter]))) gl in
+  let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (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, snd (Evd.universe_context evd)
+    Array.map (fun x -> nf (constr_of x)) !tactic_res, snd (Evd.universe_context evd)
 
 let stdlib_modules =
   [["Coq";"Setoids";"Setoid"];
@@ -281,8 +271,6 @@ let my_reference c =
 
 let new_ring_path =
   DirPath.make (List.map Id.of_string ["Ring_tac";plugin_dir;"Coq"])
-let ltac s =
-  lazy(make_kn (MPfile new_ring_path) DirPath.empty (Label.make s))
 let znew_ring_path =
   DirPath.make (List.map Id.of_string ["InitialRing";plugin_dir;"Coq"])
 let zltac s =
@@ -309,21 +297,12 @@ let coq_mk_reqe = my_constant "mk_reqe"
 let coq_semi_ring_theory = my_constant "semi_ring_theory"
 let coq_mk_seqe = my_constant "mk_seqe"
 
-let ltac_inv_morph_gen = zltac"inv_gen_phi"
-let ltac_inv_morphZ = zltac"inv_gen_phiZ"
-let ltac_inv_morphN = zltac"inv_gen_phiN"
-let ltac_inv_morphNword = zltac"inv_gen_phiNword"
 let coq_abstract = my_constant"Abstract"
 let coq_comp = my_constant"Computational"
 let coq_morph = my_constant"Morphism"
 
-(* morphism *)
-let coq_ring_morph = my_constant "ring_morph"
-let coq_semi_morph = my_constant "semi_morph"
-
 (* power function *)
 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_reference "mkhypo"
@@ -355,20 +334,6 @@ let _ = add_map "ring"
 (****************************************************************************)
 (* Ring database *)
 
-type ring_info =
-    { ring_carrier : types;
-      ring_req : constr;
-      ring_setoid : constr;
-      ring_ext : constr;
-      ring_morph : constr;
-      ring_th : constr;
-      ring_cst_tac : glob_tactic_expr;
-      ring_pow_tac : glob_tactic_expr;
-      ring_lemma1 : constr;
-      ring_lemma2 : constr;
-      ring_pre_tac : glob_tactic_expr;
-      ring_post_tac : glob_tactic_expr }
-
 module Cmap = Map.Make(Constr)
 
 let from_carrier = Summary.ref Cmap.empty ~name:"ring-tac-carrier-table"
@@ -527,8 +492,8 @@ let ring_equality env evd (r,add,mul,opp,req) =
 	  match opp with
               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
+	let setoid = Typing.e_solve_evars env evd setoid in
+	let op_morph = Typing.e_solve_evars env evd op_morph in
 	  (setoid,op_morph)
     | _ ->
 	let setoid = setoid_of_relation (Global.env ()) evd r req in
@@ -551,7 +516,7 @@ let ring_equality env evd (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
-		    msg_info
+		    Feedback.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++
@@ -560,7 +525,7 @@ let ring_equality env evd (r,add,mul,opp,req) =
 		  op_morph)
             | None ->
 		(Flags.if_verbose
-		    msg_info
+		    Feedback.msg_info
 		    (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++
 			str"and morphisms \""++pr_constr add_m_lem ++
 			str"\""++spc()++str"and \""++
@@ -588,25 +553,6 @@ let dest_ring env sigma th_spec =
     | _ -> error "bad ring structure"
 
 
-let dest_morph env sigma m_spec =
-  let m_typ = Retyping.get_type_of env sigma m_spec in
-  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_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_nounivs f (Lazy.force coq_semi_morph) ->
-        (c,czero,cone,cadd,cmul,None,None,ceqb,phi)
-    | _ -> error "bad morphism structure"
-
-
-type 'constr coeff_spec =
-    Computational of 'constr (* equality test *)
-  | Abstract (* coeffs = Z *)
-  | Morphism of 'constr (* general morphism *)
-
-
 let reflect_coeff rkind =
   (* We build an ill-typed terms on purpose... *)
   match rkind with
@@ -614,10 +560,6 @@ let reflect_coeff rkind =
     | Computational c -> lapp coq_comp [|c|]
     | Morphism m -> lapp coq_morph [|m|]
 
-type cst_tac_spec =
-    CstTac of raw_tactic_expr
-  | Closed of reference list
-
 let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac =
   match cst_tac with
       Some (CstTac t) -> Tacintern.glob_tactic t
@@ -638,7 +580,7 @@ let make_hyp_list env evd lH =
       (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
+  let l' = Typing.e_solve_evars env evd l in
     Evarutil.nf_evars_universes !evd l'
 
 let interp_power env evd pow =
@@ -686,7 +628,7 @@ let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div =
   let rk = reflect_coeff morphth in
   let params,ctx =
     exec_tactic env !evd 5 (zltac "ring_lemmas")
-      (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in
+      [sth;ext;rth;pspec;sspec;dspec;rk] in
   let lemma1 = params.(3) in
   let lemma2 = params.(4) in
 
@@ -721,41 +663,12 @@ let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div =
           ring_post_tac = posttac }) in
   ()
 
-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 Constrexpr.constr_expr * Constrexpr.constr_expr
-  | Pow_spec of cst_tac_spec * Constrexpr.constr_expr
-           (* Syntaxification tactic , correctness lemma *)
-  | 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 eq_test) ]
-  | [ "abstract" ] -> [ Ring_kind Abstract ]
-  | [ "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 ]
-  | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ]
-  | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ]
-  | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ]
-  | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] ->
-           [ Pow_spec (Closed l, pow_spec) ]
-  | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] ->
-           [ Pow_spec (CstTac cst_tac, pow_spec) ]
-  | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ]
-END
-
 let set_once s r v =
   if Option.is_empty !r then r := Some v else error (s^" cannot be set twice")
 
@@ -780,20 +693,6 @@ let process_ring_mods 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 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
-
 (*****************************************************************************)
 (* The tactics consist then only in a lookup in the ring database and
    call the appropriate ltac. *)
@@ -807,7 +706,11 @@ 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
+  in Typing.e_solve_evars env evd l
+
+let carg = Tacinterp.Value.of_constr
+let tacarg expr =
+  Tacinterp.Value.of_closure (Tacinterp.default_ist ()) expr
 
 let ltac_ring_structure e =
   let req = carg e.ring_req in
@@ -815,18 +718,18 @@ let ltac_ring_structure e =
   let ext = carg e.ring_ext in
   let morph = carg e.ring_morph in
   let th = carg e.ring_th in
-  let cst_tac = Tacexp e.ring_cst_tac in
-  let pow_tac = Tacexp e.ring_pow_tac in
+  let cst_tac = tacarg e.ring_cst_tac in
+  let pow_tac = tacarg e.ring_pow_tac in
   let lemma1 = carg e.ring_lemma1 in
   let lemma2 = carg e.ring_lemma2 in
-  let pretac = Tacexp(TacFun([None],e.ring_pre_tac)) in
-  let posttac = Tacexp(TacFun([None],e.ring_post_tac)) in
+  let pretac = tacarg (TacFun([None],e.ring_pre_tac)) in
+  let posttac = tacarg (TacFun([None],e.ring_post_tac)) in
   [req;sth;ext;morph;th;cst_tac;pow_tac;
    lemma1;lemma2;pretac;posttac]
 
-let ring_lookup (f:glob_tactic_expr) lH rl t =
-  Proofview.Goal.enter begin fun gl ->
-    let sigma = Proofview.Goal.sigma gl in
+let ring_lookup (f : Value.t) lH rl t =
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let sigma = Tacmach.New.project gl in
     let env = Proofview.Goal.env gl in
     try (* find_ring_strucure can raise an exception *)
       let evdref = ref sigma in
@@ -837,14 +740,7 @@ let ring_lookup (f:glob_tactic_expr) lH rl t =
       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]
-END
-
-
+  end }
 
 (***********************************************************************)
 
@@ -919,19 +815,6 @@ let dest_field env evd th_spec =
         (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth)
     | _ -> error "bad field structure"
 
-type field_info =
-    { field_carrier : types;
-      field_req : constr;
-      field_cst_tac : glob_tactic_expr;
-      field_pow_tac : glob_tactic_expr;
-      field_ok : constr;
-      field_simpl_eq_ok : constr;
-      field_simpl_ok : constr;
-      field_simpl_eq_in_ok : constr;
-      field_cond : constr;
-      field_pre_tac : glob_tactic_expr;
-      field_post_tac : glob_tactic_expr }
-
 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"
 
@@ -1034,7 +917,7 @@ let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power
   let rk = reflect_coeff morphth in
   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
+      [sth;ext;inv_m;fth;pspec;sspec;dspec;rk] in
   let lemma1 = params.(3) in
   let lemma2 = params.(4) in
   let lemma3 = params.(5) in
@@ -1078,15 +961,6 @@ let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power
           field_pre_tac = pretac;
           field_post_tac = posttac }) in  ()
 
-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 ]
-  | [ "completeness" constr(inj) ] -> [ Inject inj ]
-END
-
 let process_field_mods l =
   let kind = ref None in
   let set = ref None in
@@ -1111,38 +985,23 @@ let process_field_mods 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 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
-
-
 let ltac_field_structure e =
   let req = carg e.field_req in
-  let cst_tac = Tacexp e.field_cst_tac in
-  let pow_tac = Tacexp e.field_pow_tac in
+  let cst_tac = tacarg e.field_cst_tac in
+  let pow_tac = tacarg e.field_pow_tac in
   let field_ok = carg e.field_ok in
   let field_simpl_ok = carg e.field_simpl_ok in
   let field_simpl_eq_ok = carg e.field_simpl_eq_ok in
   let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in
   let cond_ok = carg e.field_cond in
-  let pretac = Tacexp(TacFun([None],e.field_pre_tac)) in
-  let posttac = Tacexp(TacFun([None],e.field_post_tac)) in
+  let pretac = tacarg (TacFun([None],e.field_pre_tac)) in
+  let posttac = tacarg (TacFun([None],e.field_post_tac)) in
   [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 =
-  Proofview.Goal.enter begin fun gl ->
-    let sigma = Proofview.Goal.sigma gl in
+let field_lookup (f : Value.t) lH rl t =
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let sigma = Tacmach.New.project gl in
     let env = Proofview.Goal.env gl in
     try
       let evdref = ref sigma in
@@ -1153,10 +1012,4 @@ let field_lookup (f:glob_tactic_expr) lH rl t =
       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 ]
-END
+  end }
diff --git a/plugins/setoid_ring/newring.mli b/plugins/setoid_ring/newring.mli
new file mode 100644
index 00000000..f417c87c
--- /dev/null
+++ b/plugins/setoid_ring/newring.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        *)
+(************************************************************************)
+
+open Names
+open Constr
+open Libnames
+open Globnames
+open Constrexpr
+open Tacexpr
+open Proof_type
+open Newring_ast
+
+val protect_tac_in : string -> Id.t -> unit Proofview.tactic
+
+val protect_tac : string -> unit Proofview.tactic
+
+val closed_term : constr -> global_reference list -> unit Proofview.tactic
+
+val process_ring_mods :
+  constr_expr ring_mod list ->
+  constr coeff_spec * (constr * constr) option *
+  cst_tac_spec option * raw_tactic_expr option *
+  raw_tactic_expr option *
+  (cst_tac_spec * constr_expr) option *
+  constr_expr option * constr_expr option
+
+val add_theory :
+  Id.t ->
+  Evd.evar_map * constr ->
+  (constr * constr) option ->
+  constr coeff_spec ->
+  cst_tac_spec option ->
+  raw_tactic_expr option * raw_tactic_expr option ->
+  (cst_tac_spec * constr_expr) option ->
+  constr_expr option ->
+  constr_expr option -> unit
+
+val ic : constr_expr -> Evd.evar_map * constr
+
+val from_name : ring_info Spmap.t ref
+
+val ring_lookup :
+  Geninterp.Val.t ->
+  constr list ->
+  constr list -> constr -> unit Proofview.tactic
+
+val process_field_mods :
+  constr_expr field_mod list ->
+  constr coeff_spec *
+  (constr * constr) option * constr option *
+  cst_tac_spec option * raw_tactic_expr option *
+  raw_tactic_expr option *
+  (cst_tac_spec * constr_expr) option *
+  constr_expr option * constr_expr option
+
+val add_field_theory :
+  Id.t ->
+  Evd.evar_map * constr ->
+  (constr * constr) option ->
+  constr coeff_spec ->
+  cst_tac_spec option ->
+  constr option ->
+  raw_tactic_expr option * raw_tactic_expr option ->
+  (cst_tac_spec * constr_expr) option ->
+  constr_expr option ->
+  constr_expr option -> unit
+
+val field_from_name : field_info Spmap.t ref
+
+val field_lookup :
+  Geninterp.Val.t ->
+  constr list ->
+  constr list -> constr -> unit Proofview.tactic
diff --git a/plugins/setoid_ring/newring_ast.mli b/plugins/setoid_ring/newring_ast.mli
new file mode 100644
index 00000000..c26fcc8d
--- /dev/null
+++ b/plugins/setoid_ring/newring_ast.mli
@@ -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 Constr
+open Libnames
+open Constrexpr
+open Tacexpr
+
+type 'constr coeff_spec =
+    Computational of 'constr (* equality test *)
+  | Abstract (* coeffs = Z *)
+  | Morphism of 'constr (* general morphism *)
+
+type cst_tac_spec =
+    CstTac of raw_tactic_expr
+  | Closed of reference list
+
+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 constr_expr * constr_expr
+  | Pow_spec of cst_tac_spec * constr_expr
+           (* Syntaxification tactic , correctness lemma *)
+  | Sign_spec of constr_expr
+  | Div_spec of constr_expr
+
+type 'constr field_mod =
+    Ring_mod of 'constr ring_mod
+  | Inject of constr_expr
+
+type ring_info =
+    { ring_carrier : types;
+      ring_req : constr;
+      ring_setoid : constr;
+      ring_ext : constr;
+      ring_morph : constr;
+      ring_th : constr;
+      ring_cst_tac : glob_tactic_expr;
+      ring_pow_tac : glob_tactic_expr;
+      ring_lemma1 : constr;
+      ring_lemma2 : constr;
+      ring_pre_tac : glob_tactic_expr;
+      ring_post_tac : glob_tactic_expr }
+
+type field_info =
+    { field_carrier : types;
+      field_req : constr;
+      field_cst_tac : glob_tactic_expr;
+      field_pow_tac : glob_tactic_expr;
+      field_ok : constr;
+      field_simpl_eq_ok : constr;
+      field_simpl_ok : constr;
+      field_simpl_eq_in_ok : constr;
+      field_cond : constr;
+      field_pre_tac : glob_tactic_expr;
+      field_post_tac : glob_tactic_expr }
diff --git a/plugins/setoid_ring/newring_plugin.mllib b/plugins/setoid_ring/newring_plugin.mllib
deleted file mode 100644
index a98392f1..00000000
--- a/plugins/setoid_ring/newring_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-Newring
-Newring_plugin_mod
diff --git a/plugins/setoid_ring/newring_plugin.mlpack b/plugins/setoid_ring/newring_plugin.mlpack
new file mode 100644
index 00000000..23663b40
--- /dev/null
+++ b/plugins/setoid_ring/newring_plugin.mlpack
@@ -0,0 +1,2 @@
+Newring
+G_newring
diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4
new file mode 100644
index 00000000..d21223d4
--- /dev/null
+++ b/plugins/ssrmatching/ssrmatching.ml4
@@ -0,0 +1,1447 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *)
+
+(* Defining grammar rules with "xx" in it automatically declares keywords too,
+ * we thus save the lexer to restore it at the end of the file *)
+let frozen_lexer = CLexer.freeze () ;;
+
+(*i camlp4use: "pa_extend.cmo" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Names
+open Pp
+open Pcoq
+open Genarg
+open Constrarg
+open Term
+open Vars
+open Topconstr
+open Libnames
+open Tactics
+open Tacticals
+open Termops
+open Namegen
+open Recordops
+open Tacmach
+open Coqlib
+open Glob_term
+open Util
+open Evd
+open Extend
+open Goptions
+open Tacexpr
+open Proofview.Notations
+open Tacinterp
+open Pretyping
+open Constr
+open Tactic
+open Extraargs
+open Ppconstr
+open Printer
+
+open Globnames
+open Misctypes
+open Decl_kinds
+open Evar_kinds
+open Constrexpr
+open Constrexpr_ops
+open Notation_term
+open Notation_ops
+open Locus
+open Locusops
+
+DECLARE PLUGIN "ssrmatching_plugin"
+
+type loc = Loc.t
+let dummy_loc = Loc.ghost
+let errorstrm = CErrors.errorlabstrm "ssrmatching"
+let loc_error loc msg = CErrors.user_err_loc (loc, msg, str msg)
+let ppnl = Feedback.msg_info
+
+(* 0 cost pp function. Active only if env variable SSRDEBUG is set *)
+(* or if SsrDebug is Set                                                  *)
+let pp_ref = ref (fun _ -> ())
+let ssr_pp s = Feedback.msg_debug (str"SSR: "++Lazy.force s)
+let _ =
+  try ignore(Sys.getenv "SSRMATCHINGDEBUG"); pp_ref := ssr_pp
+  with Not_found -> ()
+let debug b =
+  if b then pp_ref := ssr_pp else pp_ref := fun _ -> ()
+let _ =
+  Goptions.declare_bool_option
+    { Goptions.optsync  = false;
+      Goptions.optname  = "ssrmatching debugging";
+      Goptions.optkey   = ["Debug";"SsrMatching"];
+      Goptions.optdepr  = false;
+      Goptions.optread  = (fun _ -> !pp_ref == ssr_pp);
+      Goptions.optwrite = debug }
+let pp s = !pp_ref s
+
+(** Utils {{{ *****************************************************************)
+let env_size env = List.length (Environ.named_context env)
+let safeDestApp c =
+  match kind_of_term c with App (f, a) -> f, a | _ -> c, [| |]
+let get_index = function ArgArg i -> i | _ ->
+  CErrors.anomaly (str"Uninterpreted index")
+(* Toplevel constr must be globalized twice ! *)
+let glob_constr ist genv = function
+  | _, Some ce ->
+    let vars = Id.Map.fold (fun x _ accu -> Id.Set.add x accu) ist.lfun Id.Set.empty in
+    let ltacvars = { Constrintern.empty_ltac_sign with Constrintern.ltac_vars = vars } in
+    Constrintern.intern_gen WithoutTypeConstraint ~ltacvars:ltacvars genv ce
+  | rc, None -> rc
+
+(* Term printing utilities functions for deciding bracketing.  *)
+let pr_paren prx x = hov 1 (str "(" ++ prx x ++ str ")")
+(* String lexing utilities *)
+let skip_wschars s =
+  let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop
+(* We also guard characters that might interfere with the ssreflect   *)
+(* tactic syntax.                                                     *)
+let guard_term ch1 s i = match s.[i] with
+  | '(' -> false
+  | '{' | '/' | '=' -> true
+  | _ -> ch1 = '('
+(* The call 'guard s i' should return true if the contents of s *)
+(* starting at i need bracketing to avoid ambiguities.          *)
+let pr_guarded guard prc c =
+  let s = Pp.string_of_ppcmds (prc c) ^ "$" in
+  if guard s (skip_wschars s 0) then pr_paren prc c else prc c
+(* More sensible names for constr printers *)
+let pr_constr = pr_constr
+let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c
+let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c
+let prl_constr_expr = pr_lconstr_expr
+let pr_constr_expr = pr_constr_expr
+let prl_glob_constr_and_expr = function
+  | _, Some c -> prl_constr_expr c
+  | c, None -> prl_glob_constr c
+let pr_glob_constr_and_expr = function
+  | _, Some c -> pr_constr_expr c
+  | c, None -> pr_glob_constr c
+let pr_term (k, c) = pr_guarded (guard_term k) pr_glob_constr_and_expr c
+let prl_term (k, c) = pr_guarded (guard_term k) prl_glob_constr_and_expr c
+
+(** Adding a new uninterpreted generic argument type *)
+let add_genarg tag pr =
+  let wit = Genarg.make0 tag in
+  let tag = Geninterp.Val.create tag in
+  let glob ist x = (ist, x) in
+  let subst _ x = x in
+  let interp ist x = Ftactic.return (Geninterp.Val.Dyn (tag, x)) in
+  let gen_pr _ _ _ = pr in
+  let () = Genintern.register_intern0 wit glob in
+  let () = Genintern.register_subst0 wit subst in
+  let () = Geninterp.register_interp0 wit interp in
+  let () = Geninterp.register_val0 wit (Some (Geninterp.Val.Base tag)) in
+  Pptactic.declare_extra_genarg_pprule wit gen_pr gen_pr gen_pr;
+  wit
+
+(** Constructors for cast type *)
+let dC t = CastConv t
+(** Constructors for constr_expr *)
+let isCVar = function CRef (Ident _, _) -> true | _ -> false
+let destCVar = function CRef (Ident (_, id), _) -> id | _ ->
+  CErrors.anomaly (str"not a CRef")
+let mkCHole loc = CHole (loc, None, IntroAnonymous, None)
+let mkCLambda loc name ty t = 
+   CLambdaN (loc, [[loc, name], Default Explicit, ty], t)
+let mkCLetIn loc name bo t = 
+   CLetIn (loc, (loc, name), bo, t)
+let mkCCast loc t ty = CCast (loc,t, dC ty)
+(** Constructors for rawconstr *)
+let mkRHole = GHole (dummy_loc, InternalHole, IntroAnonymous, None)
+let mkRApp f args = if args = [] then f else GApp (dummy_loc, f, args)
+let mkRCast rc rt =  GCast (dummy_loc, rc, dC rt)
+let mkRLambda n s t = GLambda (dummy_loc, n, Explicit, s, t)
+
+(* ssrterm conbinators *)
+let combineCG t1 t2 f g = match t1, t2 with
+ | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None)
+ | (x, (_, Some t1)), (_, (_, Some t2)) -> x, (mkRHole, Some (f t1 t2))
+ | _, (_, (_, None)) -> CErrors.anomaly (str"have: mixed C-G constr")
+ | _ -> CErrors.anomaly (str"have: mixed G-C constr")
+let loc_ofCG = function
+ | (_, (s, None)) -> Glob_ops.loc_of_glob_constr s
+ | (_, (_, Some s)) -> Constrexpr_ops.constr_loc s
+
+let mk_term k c = k, (mkRHole, Some c)
+let mk_lterm = mk_term ' '
+
+let pf_type_of gl t = let sigma, ty = pf_type_of gl t in re_sig (sig_it gl)  sigma, ty
+
+(* }}} *)
+
+(** Profiling {{{ *************************************************************)
+type profiler = { 
+  profile : 'a 'b. ('a -> 'b) -> 'a -> 'b;
+  reset : unit -> unit;
+  print : unit -> unit }
+let profile_now = ref false
+let something_profiled = ref false
+let profilers = ref []
+let add_profiler f = profilers := f :: !profilers;;
+let profile b =
+  profile_now := b;
+  if b then List.iter (fun f -> f.reset ()) !profilers;
+  if not b then List.iter (fun f -> f.print ()) !profilers
+;;
+let _ =
+  Goptions.declare_bool_option
+    { Goptions.optsync  = false;
+      Goptions.optname  = "ssrmatching profiling";
+      Goptions.optkey   = ["SsrMatchingProfiling"];
+      Goptions.optread  = (fun _ -> !profile_now);
+      Goptions.optdepr  = false;
+      Goptions.optwrite = profile }
+let () =
+  let prof_total = 
+    let init = ref 0.0 in { 
+    profile = (fun f x -> assert false);
+    reset = (fun () -> init := Unix.gettimeofday ());
+    print = (fun () -> if !something_profiled then
+        prerr_endline 
+           (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f"
+           "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in
+  let prof_legenda = {
+    profile = (fun f x -> assert false);
+    reset = (fun () -> ());
+    print = (fun () -> if !something_profiled then begin
+        prerr_endline 
+           (Printf.sprintf "!! %39s ---------- --------- --------- ---------" 
+           (String.make 39 '-'));
+        prerr_endline 
+           (Printf.sprintf "!! %-39s %10s %9s %9s %9s" 
+           "function" "#calls" "total" "max" "average") end) } in
+  add_profiler prof_legenda;
+  add_profiler prof_total
+;;
+
+let mk_profiler s =
+  let total, calls, max = ref 0.0, ref 0, ref 0.0 in
+  let reset () = total := 0.0; calls := 0; max := 0.0 in
+  let profile f x =
+    if not !profile_now then f x else
+    let before = Unix.gettimeofday () in
+    try
+      incr calls;
+      let res = f x in
+      let after = Unix.gettimeofday () in
+      let delta = after -. before in
+      total := !total +. delta;
+      if delta > !max then max := delta;
+      res
+    with exc ->
+      let after = Unix.gettimeofday () in
+      let delta = after -. before in
+      total := !total +. delta;
+      if delta > !max then max := delta;
+      raise exc in
+  let print () =
+     if !calls <> 0 then begin
+       something_profiled := true;
+       prerr_endline
+         (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" 
+         s !calls !total !max (!total /. (float_of_int !calls))) end in
+  let prof = { profile = profile; reset = reset; print = print } in
+  add_profiler prof;
+  prof
+;;
+(* }}} *)
+
+exception NoProgress
+
+(** Unification procedures.                                *)
+
+(* To enforce the rigidity of the rooted match we always split  *)
+(* top applications, so the unification procedures operate on   *)
+(* arrays of patterns and terms.                                *)
+(* We perform three kinds of unification:                       *)
+(*  EQ: exact conversion check                                  *)
+(*  FO: first-order unification of evars, without conversion    *)
+(*  HO: higher-order unification with conversion                *)
+(* The subterm unification strategy is to find the first FO     *)
+(* match, if possible, and the first HO match otherwise, then   *)
+(* compute all the occurrences that are EQ matches for the      *)
+(* relevant subterm.                                            *)
+(*   Additional twists:                                         *)
+(*    - If FO/HO fails then we attempt to fill evars using      *)
+(*      typeclasses before raising an outright error. We also   *)
+(*      fill typeclasses even after a successful match, since   *)
+(*      beta-reduction and canonical instances may leave        *)
+(*      undefined evars.                                        *)
+(*    - We do postchecks to rule out matches that are not       *)
+(*      closed or that assign to a global evar; these can be    *)
+(*      disabled for rewrite or dependent family matches.       *)
+(*    - We do a full FO scan before turning to HO, as the FO    *)
+(*      comparison can be much faster than the HO one.          *)
+
+let unif_EQ env sigma p c =
+  let evars = existential_opt_value sigma, Evd.universes sigma in 
+  try let _ = Reduction.conv env p ~evars c in true with _ -> false
+
+let unif_EQ_args env sigma pa a =
+  let n = Array.length pa in
+  let rec loop i = (i = n) || unif_EQ env sigma pa.(i) a.(i) && loop (i + 1) in
+  loop 0
+
+let prof_unif_eq_args = mk_profiler "unif_EQ_args";;
+let unif_EQ_args env sigma pa a =
+  prof_unif_eq_args.profile (unif_EQ_args env sigma pa) a 
+;;
+
+let unif_HO env ise p c = Evarconv.the_conv_x env p c ise
+
+let unif_HOtype env ise p c = Evarconv.the_conv_x_leq env p c ise
+
+let unif_HO_args env ise0 pa i ca =
+  let n = Array.length pa in
+  let rec loop ise j =
+    if j = n then ise else loop (unif_HO env ise pa.(j) ca.(i + j)) (j + 1) in
+  loop ise0 0
+
+(* FO unification should boil down to calling w_unify with no_delta, but  *)
+(* alas things are not so simple: w_unify does partial type-checking,     *)
+(* which breaks down when the no-delta flag is on (as the Coq type system *)
+(* requires full convertibility. The workaround here is to convert all    *)
+(* evars into metas, since 8.2 does not TC metas. This means some lossage *)
+(* for HO evars, though hopefully Miller patterns can pick up some of     *)
+(* those cases, and HO matching will mop up the rest.                     *)
+let flags_FO =
+  let flags =
+    { (Unification.default_no_delta_unify_flags ()).Unification.core_unify_flags
+      with
+        Unification.modulo_conv_on_closed_terms = None;
+        Unification.modulo_eta = true;
+        Unification.modulo_betaiota = true;
+        Unification.modulo_delta_types = full_transparent_state}
+  in
+  { Unification.core_unify_flags = flags;
+    Unification.merge_unify_flags = flags;
+    Unification.subterm_unify_flags = flags;
+    Unification.allow_K_in_toplevel_higher_order_unification = false;
+    Unification.resolve_evars =
+      (Unification.default_no_delta_unify_flags ()).Unification.resolve_evars
+  }
+let unif_FO env ise p c =
+  Unification.w_unify env ise Reduction.CONV ~flags:flags_FO p c
+
+(* Perform evar substitution in main term and prune substitution. *)
+let nf_open_term sigma0 ise c =
+  let s = ise and s' = ref sigma0 in
+  let rec nf c' = match kind_of_term c' with
+  | Evar ex ->
+    begin try nf (existential_value s ex) with _ ->
+    let k, a = ex in let a' = Array.map nf a in
+    if not (Evd.mem !s' k) then
+      s' := Evd.add !s' k (Evarutil.nf_evar_info s (Evd.find s k));
+    mkEvar (k, a')
+    end
+  | _ -> map_constr nf c' in
+  let copy_def k evi () =
+    if evar_body evi != Evd.Evar_empty then () else
+    match Evd.evar_body (Evd.find s k) with
+    | Evar_defined c' -> s' := Evd.define k (nf c') !s'
+    | _ -> () in
+  let c' = nf c in let _ = Evd.fold copy_def sigma0 () in
+  !s', Evd.evar_universe_context s, c'
+
+let unif_end env sigma0 ise0 pt ok =
+  let ise = Evarconv.solve_unif_constraints_with_heuristics env ise0 in
+  let s, uc, t = nf_open_term sigma0 ise pt in
+  let ise1 = create_evar_defs s in
+  let ise1 = Evd.set_universe_context ise1 uc in
+  let ise2 = Typeclasses.resolve_typeclasses ~fail:true env ise1 in
+  if not (ok ise) then raise NoProgress else
+  if ise2 == ise1 then (s, uc, t)
+  else
+    let s, uc', t = nf_open_term sigma0 ise2 t in
+    s, Evd.union_evar_universe_context uc uc', t
+
+let pf_unif_HO gl sigma pt p c =
+  let env = pf_env gl in
+  let ise = unif_HO env (create_evar_defs sigma) p c in
+  unif_end env (project gl) ise pt (fun _ -> true)
+
+let unify_HO env sigma0 t1 t2 =
+  let sigma = unif_HO env sigma0 t1 t2 in
+  let sigma, uc, _ = unif_end env sigma0 sigma t2 (fun _ -> true) in
+  Evd.set_universe_context sigma uc
+
+let pf_unify_HO gl t1 t2 =
+  let env, sigma0, si = pf_env gl, project gl, sig_it gl in
+  let sigma = unify_HO env sigma0 t1 t2 in
+  re_sig si sigma
+
+(* This is what the definition of iter_constr should be... *)
+let iter_constr_LR f c = match kind_of_term c with
+  | Evar (k, a) -> Array.iter f a
+  | Cast (cc, _, t) -> f cc; f t  
+  | Prod (_, t, b) | Lambda (_, t, b)  -> f t; f b
+  | LetIn (_, v, t, b) -> f v; f t; f b
+  | App (cf, a) -> f cf; Array.iter f a
+  | Case (_, p, v, b) -> f v; f p; Array.iter f b
+  | Fix (_, (_, t, b)) | CoFix (_, (_, t, b)) ->
+    for i = 0 to Array.length t - 1 do f t.(i); f b.(i) done
+  | Proj(_,a) -> f a
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _ | Construct _) -> ()
+
+(* The comparison used to determine which subterms matches is KEYED        *)
+(* CONVERSION. This looks for convertible terms that either have the same  *)
+(* same head constant as pat if pat is an application (after beta-iota),   *)
+(* or start with the same constr constructor (esp. for LetIn); this is     *)
+(* disregarded if the head term is let x := ... in x, and casts are always *)
+(* ignored and removed).                                                   *)
+(* Record projections get special treatment: in addition to the projection *)
+(* constant itself, ssreflect also recognizes head constants of canonical  *)
+(* projections.                                                            *)
+
+exception NoMatch
+type ssrdir = L2R | R2L
+let pr_dir_side = function L2R -> str "LHS" | R2L -> str "RHS"
+let inv_dir = function L2R -> R2L | R2L -> L2R
+
+
+type pattern_class =
+  | KpatFixed
+  | KpatConst
+  | KpatEvar of existential_key
+  | KpatLet
+  | KpatLam
+  | KpatRigid
+  | KpatFlex
+  | KpatProj of constant
+
+type tpattern = {
+  up_k : pattern_class;
+  up_FO : constr;
+  up_f : constr;
+  up_a : constr array;
+  up_t : constr;                      (* equation proof term or matched term *)
+  up_dir : ssrdir;                    (* direction of the rule *)
+  up_ok : constr -> evar_map -> bool; (* progess test for rewrite *)
+  }
+
+let all_ok _ _ = true
+
+let proj_nparams c =
+  try 1 + Recordops.find_projection_nparams (ConstRef c) with _ -> 0
+
+let isFixed c = match kind_of_term c with
+  | Var _ | Ind _ | Construct _ | Const _ | Proj _ -> true
+  | _ -> false
+
+let isRigid c = match kind_of_term c with
+  | Prod _ | Sort _ | Lambda _ | Case _ | Fix _ | CoFix _ -> true
+  | _ -> false
+
+exception UndefPat
+
+let hole_var = mkVar (id_of_string "_")
+let pr_constr_pat c0 =
+  let rec wipe_evar c =
+    if isEvar c then hole_var else map_constr wipe_evar c in
+  pr_constr (wipe_evar c0)
+
+(* Turn (new) evars into metas *)
+let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 =
+  let ise = ref ise0 in
+  let sigma = ref ise0 in
+  let nenv = env_size env + if hack then 1 else 0 in
+  let rec put c = match kind_of_term c with
+  | Evar (k, a as ex) ->
+    begin try put (existential_value !sigma ex)
+    with NotInstantiatedEvar ->
+    if Evd.mem sigma0 k then map_constr put c else
+    let evi = Evd.find !sigma k in
+    let dc = List.firstn (max 0 (Array.length a - nenv)) (evar_filtered_context evi) in
+    let abs_dc (d, c) = function
+    | Context.Named.Declaration.LocalDef (x, b, t) ->
+        d, mkNamedLetIn x (put b) (put t) c
+    | Context.Named.Declaration.LocalAssum (x, t) ->
+        mkVar x :: d, mkNamedProd x (put t) c in
+    let a, t =
+      Context.Named.fold_inside abs_dc ~init:([], (put evi.evar_concl)) dc in
+    let m = Evarutil.new_meta () in
+    ise := meta_declare m t !ise;
+    sigma := Evd.define k (applist (mkMeta m, a)) !sigma;
+    put (existential_value !sigma ex)
+    end
+  | _ -> map_constr put c in
+  let c1 = put c0 in !ise, c1
+
+(* Compile a match pattern from a term; t is the term to fill. *)
+(* p_origin can be passed to obtain a better error message     *)
+let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p =
+  let k, f, a =
+    let f, a = Reductionops.whd_betaiota_stack ise p in
+    match kind_of_term f with
+    | Const (p,_) ->
+      let np = proj_nparams p in
+      if np = 0 || np > List.length a then KpatConst, f, a else
+      let a1, a2 = List.chop np a in KpatProj p, applist(f, a1), a2
+    | Proj (p,arg) -> KpatProj (Projection.constant p), f, a
+    | Var _ | Ind _ | Construct _ -> KpatFixed, f, a
+    | Evar (k, _) ->
+      if Evd.mem sigma0 k then KpatEvar k, f, a else
+      if a <> [] then KpatFlex, f, a else 
+      (match p_origin with None -> CErrors.error "indeterminate pattern"
+      | Some (dir, rule) ->
+	errorstrm (str "indeterminate " ++ pr_dir_side dir
+          ++ str " in " ++ pr_constr_pat rule))
+    | LetIn (_, v, _, b) ->
+      if b <> mkRel 1 then KpatLet, f, a else KpatFlex, v, a
+    | Lambda _ -> KpatLam, f, a
+    | _ -> KpatRigid, f, a in
+  let aa = Array.of_list a in
+  let ise', p' = evars_for_FO ~hack env sigma0 ise (mkApp (f, aa)) in
+  ise',
+  { up_k = k; up_FO = p'; up_f = f; 
+    up_a = aa; up_ok = ok; up_dir = dir; up_t = t}
+
+(* Specialize a pattern after a successful match: assign a precise head *)
+(* kind and arity for Proj and Flex patterns.                           *)
+let ungen_upat lhs (sigma, uc, t) u =
+  let f, a = safeDestApp lhs in
+  let k = match kind_of_term f with
+  | Var _ | Ind _ | Construct _ -> KpatFixed
+  | Const _ -> KpatConst
+  | Evar (k, _) -> if is_defined sigma k then raise NoMatch else KpatEvar k
+  | LetIn _ -> KpatLet
+  | Lambda _ -> KpatLam
+  | _ -> KpatRigid in
+  sigma, uc, {u with up_k = k; up_FO = lhs; up_f = f; up_a = a; up_t = t}
+
+let nb_cs_proj_args pc f u =
+  let na k =
+    List.length (snd (lookup_canonical_conversion (ConstRef pc, k))).o_TCOMPS in
+  try match kind_of_term f with
+  | Prod _ -> na Prod_cs
+  | Sort s -> na (Sort_cs (family_of_sort s))
+  | Const (c',_) when Constant.equal c' pc ->
+      begin match kind_of_term u.up_f with
+      | App(_,args) -> Array.length args
+      | Proj _ -> 0 (* if splay_app calls expand_projection, this has to be
+                       the number of arguments including the projected *)
+      | _ -> assert false
+      end
+  | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (global_of_constr f))
+  | _ -> -1
+  with Not_found -> -1
+
+let isEvar_k k f =
+  match kind_of_term f with Evar (k', _) -> k = k' | _ -> false
+
+let nb_args c =
+  match kind_of_term c with App (_, a) -> Array.length a | _ -> 0
+
+let mkSubArg i a = if i = Array.length a then a else Array.sub a 0 i
+let mkSubApp f i a = if i = 0 then f else mkApp (f, mkSubArg i a)
+
+let splay_app ise =
+  let rec loop c a = match kind_of_term c with
+  | App (f, a') -> loop f (Array.append a' a)
+  | Cast (c', _, _) -> loop c' a
+  | Evar ex ->
+    (try loop (existential_value ise ex) a with _ -> c, a)
+  | _ -> c, a in
+  fun c -> match kind_of_term c with
+  | App (f, a) -> loop f a
+  | Cast _ | Evar _ -> loop c [| |]
+  | _ -> c, [| |]
+
+let filter_upat i0 f n u fpats =
+  let na = Array.length u.up_a in
+  if n < na then fpats else
+  let np = match u.up_k with
+  | KpatConst when Term.eq_constr u.up_f f -> na
+  | KpatFixed when Term.eq_constr u.up_f f -> na 
+  | KpatEvar k when isEvar_k k f -> na
+  | KpatLet when isLetIn f -> na
+  | KpatLam when isLambda f -> na
+  | KpatRigid when isRigid f -> na
+  | KpatFlex -> na
+  | KpatProj pc ->
+    let np = na + nb_cs_proj_args pc f u in if n < np then -1 else np
+  | _ -> -1 in
+  if np < na then fpats else
+  let () = if !i0 < np then i0 := n in (u, np) :: fpats
+
+let eq_prim_proj c t = match kind_of_term t with
+  | Proj(p,_) -> Constant.equal (Projection.constant p) c
+  | _ -> false
+
+let filter_upat_FO i0 f n u fpats =
+  let np = nb_args u.up_FO in
+  if n < np then fpats else
+  let ok = match u.up_k with
+  | KpatConst -> Term.eq_constr u.up_f f 
+  | KpatFixed -> Term.eq_constr u.up_f f 
+  | KpatEvar k -> isEvar_k k f
+  | KpatLet -> isLetIn f
+  | KpatLam -> isLambda f
+  | KpatRigid -> isRigid f
+  | KpatProj pc -> Term.eq_constr f (mkConst pc) || eq_prim_proj pc f
+  | KpatFlex -> i0 := n; true in
+  if ok then begin if !i0 < np then i0 := np; (u, np) :: fpats end else fpats
+
+exception FoundUnif of (evar_map * evar_universe_context * tpattern)
+(* Note: we don't update env as we descend into the term, as the primitive *)
+(* unification procedure always rejects subterms with bound variables.     *)
+
+let dont_impact_evars_in cl =
+  let evs_in_cl = Evd.evars_of_term cl in
+  fun sigma -> Evar.Set.for_all (fun k ->
+    try let _ = Evd.find_undefined sigma k in true
+    with Not_found -> false) evs_in_cl
+
+(* We are forced to duplicate code between the FO/HO matching because we    *)
+(* have to work around several kludges in unify.ml:                         *)
+(*  - w_unify drops into second-order unification when the pattern is an    *)
+(*    application whose head is a meta.                                     *)
+(*  - w_unify tries to unify types without subsumption when the pattern     *)
+(*    head is an evar or meta (e.g., it fails on ?1 = nat when ?1 : Type).  *)
+(*  - w_unify expands let-in (zeta conversion) eagerly, whereas we want to  *)
+(*    match a head let rigidly.                                             *)
+let match_upats_FO upats env sigma0 ise orig_c =
+  let dont_impact_evars = dont_impact_evars_in orig_c in
+  let rec loop c =
+    let f, a = splay_app ise c in let i0 = ref (-1) in
+    let fpats =
+      List.fold_right (filter_upat_FO i0 f (Array.length a)) upats [] in
+    while !i0 >= 0 do
+      let i = !i0 in i0 := -1;
+      let c' = mkSubApp f i a in
+      let one_match (u, np) =
+         let skip =
+           if i <= np then i < np else
+           if u.up_k == KpatFlex then begin i0 := i - 1; false end else
+           begin if !i0 < np then i0 := np; true end in
+         if skip || not (closed0 c') then () else try
+           let _ = match u.up_k with
+           | KpatFlex ->
+             let kludge v = mkLambda (Anonymous, mkProp, v) in
+             unif_FO env ise (kludge u.up_FO) (kludge c')
+           | KpatLet ->
+             let kludge vla =
+               let vl, a = safeDestApp vla in
+               let x, v, t, b = destLetIn vl in
+               mkApp (mkLambda (x, t, b), Array.cons v a) in
+             unif_FO env ise (kludge u.up_FO) (kludge c')
+           | _ -> unif_FO env ise u.up_FO c' in
+           let ise' = (* Unify again using HO to assign evars *)
+             let p = mkApp (u.up_f, u.up_a) in
+             try unif_HO env ise p c' with _ -> raise NoMatch in
+           let lhs = mkSubApp f i a in
+           let pt' = unif_end env sigma0 ise' u.up_t (u.up_ok lhs) in
+           raise (FoundUnif (ungen_upat lhs pt' u))
+       with FoundUnif (s,_,_) as sig_u when dont_impact_evars s -> raise sig_u
+       | Not_found -> CErrors.anomaly (str"incomplete ise in match_upats_FO")
+       | _ -> () in
+    List.iter one_match fpats
+  done;
+  iter_constr_LR loop f; Array.iter loop a in
+  try loop orig_c with Invalid_argument _ -> CErrors.anomaly (str"IN FO")
+
+let prof_FO = mk_profiler "match_upats_FO";;
+let match_upats_FO upats env sigma0 ise c =
+  prof_FO.profile (match_upats_FO upats env sigma0) ise c
+;;
+
+
+let match_upats_HO ~on_instance upats env sigma0 ise c =
+  let dont_impact_evars = dont_impact_evars_in c in
+ let it_did_match = ref false in
+ let failed_because_of_TC = ref false in
+ let rec aux upats env sigma0 ise c =
+  let f, a = splay_app ise c in let i0 = ref (-1) in
+  let fpats = List.fold_right (filter_upat i0 f (Array.length a)) upats [] in
+  while !i0 >= 0 do
+    let i = !i0 in i0 := -1;
+    let one_match (u, np) =
+      let skip =
+        if i <= np then i < np else
+        if u.up_k == KpatFlex then begin i0 := i - 1; false end else
+        begin if !i0 < np then i0 := np; true end in
+      if skip then () else try
+        let ise' = match u.up_k with
+        | KpatFixed | KpatConst -> ise
+        | KpatEvar _ ->
+          let _, pka = destEvar u.up_f and _, ka = destEvar f in
+          unif_HO_args env ise pka 0 ka
+        | KpatLet ->
+          let x, v, t, b = destLetIn f in
+          let _, pv, _, pb = destLetIn u.up_f in
+          let ise' = unif_HO env ise pv v in
+          unif_HO
+            (Environ.push_rel (Context.Rel.Declaration.LocalAssum(x, t)) env)
+            ise' pb b
+        | KpatFlex | KpatProj _ ->
+          unif_HO env ise u.up_f (mkSubApp f (i - Array.length u.up_a) a)
+        | _ -> unif_HO env ise u.up_f f in
+        let ise'' = unif_HO_args env ise' u.up_a (i - Array.length u.up_a) a in
+        let lhs = mkSubApp f i a in
+        let pt' = unif_end env sigma0 ise'' u.up_t (u.up_ok lhs) in
+        on_instance (ungen_upat lhs pt' u)
+      with FoundUnif (s,_,_) as sig_u when dont_impact_evars s -> raise sig_u
+      | NoProgress -> it_did_match := true
+      | Pretype_errors.PretypeError
+         (_,_,Pretype_errors.UnsatisfiableConstraints _) ->
+          failed_because_of_TC:=true
+      | e when CErrors.noncritical e -> () in
+    List.iter one_match fpats
+  done;
+  iter_constr_LR (aux upats env sigma0 ise) f;
+  Array.iter (aux upats env sigma0 ise) a
+ in
+ aux upats env sigma0 ise c;
+ if !it_did_match then raise NoProgress;
+ !failed_because_of_TC
+
+let prof_HO = mk_profiler "match_upats_HO";;
+let match_upats_HO ~on_instance upats env sigma0 ise c =
+  prof_HO.profile (match_upats_HO ~on_instance upats env sigma0) ise c
+;;
+
+
+let fixed_upat = function
+| {up_k = KpatFlex | KpatEvar _ | KpatProj _} -> false 
+| {up_t = t} -> not (occur_existential t)
+
+let do_once r f = match !r with Some _ -> () | None -> r := Some (f ())
+
+let assert_done r = 
+  match !r with Some x -> x | None -> CErrors.anomaly (str"do_once never called")
+
+let assert_done_multires r = 
+  match !r with
+  | None -> CErrors.anomaly (str"do_once never called")
+  | Some (n, xs) ->
+      r := Some (n+1,xs);
+      try List.nth xs n with Failure _ -> raise NoMatch
+
+type subst = Environ.env -> Term.constr -> Term.constr -> int -> Term.constr
+type find_P = 
+  Environ.env -> Term.constr -> int ->
+  k:subst ->
+     Term.constr
+type conclude = unit ->
+  Term.constr * ssrdir * (Evd.evar_map * Evd.evar_universe_context * Term.constr)
+
+(* upats_origin makes a better error message only            *)
+let mk_tpattern_matcher ?(all_instances=false)
+  ?(raise_NoMatch=false) ?upats_origin sigma0 occ (ise, upats)
+=
+  let nocc = ref 0 and skip_occ = ref false in
+  let use_occ, occ_list = match occ with
+  | Some (true, ol) -> ol = [], ol
+  | Some (false, ol) -> ol <> [], ol
+  | None -> false, [] in
+  let max_occ = List.fold_right max occ_list 0 in
+  let subst_occ =
+    let occ_set = Array.make max_occ (not use_occ) in
+    let _ = List.iter (fun i -> occ_set.(i - 1) <- use_occ) occ_list in
+    let _ = if max_occ = 0 then skip_occ := use_occ in
+    fun () -> incr nocc;
+    if !nocc = max_occ then skip_occ := use_occ;
+    if !nocc <= max_occ then occ_set.(!nocc - 1) else not use_occ in
+  let upat_that_matched = ref None in
+  let match_EQ env sigma u = 
+    match u.up_k with
+    | KpatLet ->
+      let x, pv, t, pb = destLetIn u.up_f in
+      let env' =
+        Environ.push_rel (Context.Rel.Declaration.LocalAssum(x, t)) env in
+      let match_let f = match kind_of_term f with
+      | LetIn (_, v, _, b) -> unif_EQ env sigma pv v && unif_EQ env' sigma pb b
+      | _ -> false in match_let
+    | KpatFixed -> Term.eq_constr u.up_f
+    | KpatConst -> Term.eq_constr u.up_f
+    | KpatLam -> fun c ->
+       (match kind_of_term c with
+       | Lambda _ -> unif_EQ env sigma u.up_f c
+       | _ -> false)
+    | _ -> unif_EQ env sigma u.up_f in
+let p2t p = mkApp(p.up_f,p.up_a) in 
+let source () = match upats_origin, upats with
+  | None, [p] -> 
+      (if fixed_upat p then str"term " else str"partial term ") ++ 
+      pr_constr_pat (p2t p) ++ spc()
+  | Some (dir,rule), [p] -> str"The " ++ pr_dir_side dir ++ str" of " ++ 
+      pr_constr_pat rule ++ fnl() ++ ws 4 ++ pr_constr_pat (p2t p) ++ fnl()
+  | Some (dir,rule), _ -> str"The " ++ pr_dir_side dir ++ str" of " ++ 
+      pr_constr_pat rule ++ spc()
+  | _, [] | None, _::_::_ ->
+      CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin") in
+let on_instance, instances =
+  let instances = ref [] in
+  (fun x ->
+    if all_instances then instances := !instances @ [x]
+    else raise (FoundUnif x)),
+  (fun () -> !instances) in
+let rec uniquize = function
+  | [] -> []
+  | (sigma,_,{ up_f = f; up_a = a; up_t = t } as x) :: xs ->
+    let t = Reductionops.nf_evar sigma t in
+    let f = Reductionops.nf_evar sigma f in
+    let a = Array.map (Reductionops.nf_evar sigma) a in
+    let neq (sigma1,_,{ up_f = f1; up_a = a1; up_t = t1 }) =
+      let t1 = Reductionops.nf_evar sigma1 t1 in
+      let f1 = Reductionops.nf_evar sigma1 f1 in
+      let a1 = Array.map (Reductionops.nf_evar sigma1) a1 in
+      not (Term.eq_constr t t1 &&
+           Term.eq_constr f f1 && CArray.for_all2 Term.eq_constr a a1) in
+    x :: uniquize (List.filter neq xs) in
+
+((fun env c h ~k -> 
+  do_once upat_that_matched (fun () -> 
+    let failed_because_of_TC = ref false in
+    try
+      if not all_instances then match_upats_FO upats env sigma0 ise c;
+      failed_because_of_TC:=match_upats_HO ~on_instance upats env sigma0 ise c;
+      raise NoMatch
+    with FoundUnif sigma_u -> 0,[sigma_u]
+    | (NoMatch|NoProgress) when all_instances && instances () <> [] ->
+      0, uniquize (instances ())
+    | NoMatch when (not raise_NoMatch) ->
+      if !failed_because_of_TC then
+        errorstrm (source ()++strbrk"matches but type classes inference fails")
+      else
+        errorstrm (source () ++ str "does not match any subterm of the goal")
+    | NoProgress when (not raise_NoMatch) ->
+        let dir = match upats_origin with Some (d,_) -> d | _ ->
+          CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin") in
+        errorstrm (str"all matches of "++source()++
+          str"are equal to the " ++ pr_dir_side (inv_dir dir))
+    | NoProgress -> raise NoMatch);
+  let sigma, _, ({up_f = pf; up_a = pa} as u) =
+    if all_instances then assert_done_multires upat_that_matched
+    else List.hd (snd(assert_done upat_that_matched)) in
+(*   pp(lazy(str"sigma@tmatch=" ++ pr_evar_map None sigma)); *)
+  if !skip_occ then ((*ignore(k env u.up_t 0);*) c) else
+  let match_EQ = match_EQ env sigma u in
+  let pn = Array.length pa in
+  let rec subst_loop (env,h as acc) c' =
+    if !skip_occ then c' else
+    let f, a = splay_app sigma c' in
+    if Array.length a >= pn && match_EQ f && unif_EQ_args env sigma pa a then
+      let a1, a2 = Array.chop (Array.length pa) a in
+      let fa1 = mkApp (f, a1) in
+      let f' = if subst_occ () then k env u.up_t fa1 h else fa1 in
+      mkApp (f', Array.map_left (subst_loop acc) a2)
+    else
+      (* TASSI: clear letin values to avoid unfolding *)
+      let inc_h rd (env,h') =
+        let ctx_item =
+          match rd with
+          | Context.Rel.Declaration.LocalAssum _ as x -> x
+          | Context.Rel.Declaration.LocalDef (x,_,y) ->
+              Context.Rel.Declaration.LocalAssum(x,y) in
+        Environ.push_rel ctx_item env, h' + 1 in
+      let f' = map_constr_with_binders_left_to_right inc_h subst_loop acc f in
+      mkApp (f', Array.map_left (subst_loop acc) a) in
+  subst_loop (env,h) c) : find_P),
+((fun () ->
+  let sigma, uc, ({up_f = pf; up_a = pa} as u) =
+    match !upat_that_matched with
+    | Some (_,x) -> List.hd x | None when raise_NoMatch -> raise NoMatch
+    | None -> CErrors.anomaly (str"companion function never called") in
+  let p' = mkApp (pf, pa) in
+  if max_occ <= !nocc then p', u.up_dir, (sigma, uc, u.up_t)
+  else errorstrm (str"Only " ++ int !nocc ++ str" < " ++ int max_occ ++
+        str(String.plural !nocc " occurence") ++ match upats_origin with
+        | None -> str" of" ++ spc() ++ pr_constr_pat p'
+        | Some (dir,rule) -> str" of the " ++ pr_dir_side dir ++ fnl() ++
+            ws 4 ++ pr_constr_pat p' ++ fnl () ++ 
+            str"of " ++ pr_constr_pat rule)) : conclude)
+
+type ('ident, 'term) ssrpattern = 
+  | T of 'term
+  | In_T of 'term
+  | X_In_T of 'ident * 'term     
+  | In_X_In_T of 'ident * 'term     
+  | E_In_X_In_T of 'term * 'ident * 'term     
+  | E_As_X_In_T of 'term * 'ident * 'term     
+        
+let pr_pattern = function
+  | T t -> prl_term t
+  | In_T t -> str "in " ++ prl_term t
+  | X_In_T (x,t) -> prl_term x ++ str " in " ++ prl_term t
+  | In_X_In_T (x,t) -> str "in " ++ prl_term x ++ str " in " ++ prl_term t
+  | E_In_X_In_T (e,x,t) ->
+      prl_term e ++ str " in " ++ prl_term x ++ str " in " ++ prl_term t
+  | E_As_X_In_T (e,x,t) ->
+      prl_term e ++ str " as " ++ prl_term x ++ str " in " ++ prl_term t
+
+let pr_pattern_w_ids = function
+  | T t -> prl_term t
+  | In_T t -> str "in " ++ prl_term t
+  | X_In_T (x,t) -> pr_id x ++ str " in " ++ prl_term t
+  | In_X_In_T (x,t) -> str "in " ++ pr_id x ++ str " in " ++ prl_term t
+  | E_In_X_In_T (e,x,t) ->
+      prl_term e ++ str " in " ++ pr_id x ++ str " in " ++ prl_term t
+  | E_As_X_In_T (e,x,t) ->
+      prl_term e ++ str " as " ++ pr_id x ++ str " in " ++ prl_term t
+
+let pr_pattern_aux pr_constr = function
+  | T t -> pr_constr t
+  | In_T t -> str "in " ++ pr_constr t
+  | X_In_T (x,t) -> pr_constr x ++ str " in " ++ pr_constr t
+  | In_X_In_T (x,t) -> str "in " ++ pr_constr x ++ str " in " ++ pr_constr t
+  | E_In_X_In_T (e,x,t) ->
+      pr_constr e ++ str " in " ++ pr_constr x ++ str " in " ++ pr_constr t
+  | E_As_X_In_T (e,x,t) ->
+      pr_constr e ++ str " as " ++ pr_constr x ++ str " in " ++ pr_constr t
+let pp_pattern (sigma, p) =
+  pr_pattern_aux (fun t -> pr_constr_pat (pi3 (nf_open_term sigma sigma t))) p
+let pr_cpattern = pr_term
+let pr_rpattern _ _ _ = pr_pattern
+
+let pr_option f = function None -> mt() | Some x -> f x
+let pr_ssrpattern _ _ _ = pr_option pr_pattern
+let pr_pattern_squarep = pr_option (fun r -> str "[" ++ pr_pattern r ++ str "]")
+let pr_ssrpattern_squarep _ _ _ = pr_pattern_squarep
+let pr_pattern_roundp = pr_option (fun r -> str "(" ++ pr_pattern r ++ str ")")
+let pr_ssrpattern_roundp  _ _ _ = pr_pattern_roundp
+
+let wit_rpatternty = add_genarg "rpatternty" pr_pattern
+
+let glob_ssrterm gs = function
+  | k, (_, Some c) -> k,
+      let x = Tacintern.intern_constr gs c in
+      fst x, Some c
+  | ct -> ct
+
+(* This piece of code asserts the following notations are reserved *)
+(* Reserved Notation "( a 'in' b )"        (at level 0).           *)
+(* Reserved Notation "( a 'as' b )"        (at level 0).           *)
+(* Reserved Notation "( a 'in' b 'in' c )" (at level 0).           *)
+(* Reserved Notation "( a 'as' b 'in' c )" (at level 0).           *)
+let glob_cpattern gs p =
+  pp(lazy(str"globbing pattern: " ++ pr_term p));
+  let glob x = snd (glob_ssrterm gs (mk_lterm x)) in
+  let encode k s l =
+    let name = Name (id_of_string ("_ssrpat_" ^ s)) in
+    k, (mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None) in
+  let bind_in t1 t2 =
+    let d = dummy_loc in let n = Name (destCVar t1) in
+    fst (glob (mkCCast d (mkCHole d) (mkCLambda d n (mkCHole d) t2))) in
+  let check_var t2 = if not (isCVar t2) then
+    loc_error (constr_loc t2) "Only identifiers are allowed here" in
+  match p with
+  | _, (_, None) as x -> x
+  | k, (v, Some t) as orig ->
+     if k = 'x' then glob_ssrterm gs ('(', (v, Some t)) else
+     match t with
+     | CNotation(_, "( _ in _ )", ([t1; t2], [], [])) ->
+         (try match glob t1, glob t2 with
+         | (r1, None), (r2, None) -> encode k "In" [r1;r2]
+         | (r1, Some _), (r2, Some _) when isCVar t1 ->
+             encode k "In" [r1; r2; bind_in t1 t2]
+         | (r1, Some _), (r2, Some _) -> encode k "In" [r1; r2]
+         | _ -> CErrors.anomaly (str"where are we?")
+         with _ when isCVar t1 -> encode k "In" [bind_in t1 t2])
+     | CNotation(_, "( _ in _ in _ )", ([t1; t2; t3], [], [])) ->
+         check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3]
+     | CNotation(_, "( _ as _ )", ([t1; t2], [], [])) ->
+         encode k "As" [fst (glob t1); fst (glob t2)]
+     | CNotation(_, "( _ as _ in _ )", ([t1; t2; t3], [], [])) ->
+         check_var t2; encode k "As" [fst (glob t1); bind_in t2 t3]
+     | _ -> glob_ssrterm gs orig
+;;
+
+let glob_rpattern s p =
+  match p with
+  | T t -> T (glob_cpattern s t)
+  | In_T t -> In_T (glob_ssrterm s t)
+  | X_In_T(x,t) -> X_In_T (x,glob_ssrterm s t)
+  | In_X_In_T(x,t) -> In_X_In_T (x,glob_ssrterm s t)
+  | E_In_X_In_T(e,x,t) -> E_In_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t)
+  | E_As_X_In_T(e,x,t) -> E_As_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t)
+
+let subst_ssrterm s (k, c) = k, Tacsubst.subst_glob_constr_and_expr s c
+
+let subst_rpattern s = function
+  | T t -> T (subst_ssrterm s t)
+  | In_T t -> In_T (subst_ssrterm s t)
+  | X_In_T(x,t) -> X_In_T (x,subst_ssrterm s t)
+  | In_X_In_T(x,t) -> In_X_In_T (x,subst_ssrterm s t)
+  | E_In_X_In_T(e,x,t) -> E_In_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t)
+  | E_As_X_In_T(e,x,t) -> E_As_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t)
+
+ARGUMENT EXTEND rpattern
+  TYPED AS rpatternty
+  PRINTED BY pr_rpattern
+  GLOBALIZED BY glob_rpattern
+  SUBSTITUTED BY subst_rpattern
+  | [ lconstr(c) ] -> [ T (mk_lterm c) ]
+  | [ "in" lconstr(c) ] -> [ In_T (mk_lterm c) ]
+  | [ lconstr(x) "in" lconstr(c) ] -> 
+    [ X_In_T (mk_lterm x, mk_lterm c) ]
+  | [ "in" lconstr(x) "in" lconstr(c) ] -> 
+    [ In_X_In_T (mk_lterm x, mk_lterm c) ]
+  | [ lconstr(e) "in" lconstr(x) "in" lconstr(c) ] -> 
+    [ E_In_X_In_T (mk_lterm e, mk_lterm x, mk_lterm c) ]
+  | [ lconstr(e) "as" lconstr(x) "in" lconstr(c) ] -> 
+    [ E_As_X_In_T (mk_lterm e, mk_lterm x, mk_lterm c) ]
+END
+
+
+
+type cpattern = char * glob_constr_and_expr
+let tag_of_cpattern = fst
+let loc_of_cpattern = loc_ofCG
+let cpattern_of_term t = t
+type occ = (bool * int list) option
+
+type rpattern = (cpattern, cpattern) ssrpattern
+let pr_rpattern = pr_pattern
+
+type pattern = Evd.evar_map * (Term.constr, Term.constr) ssrpattern
+
+
+let id_of_cpattern = function
+  | _,(_,Some (CRef (Ident (_, x), _))) -> Some x
+  | _,(_,Some (CAppExpl (_, (_, Ident (_, x), _), []))) -> Some x
+  | _,(GRef (_, VarRef x, _) ,None) -> Some x
+  | _ -> None
+let id_of_Cterm t = match id_of_cpattern t with
+  | Some x -> x
+  | None -> loc_error (loc_of_cpattern t) "Only identifiers are allowed here"
+
+let of_ftactic ftac gl =
+  let r = ref None in
+  let tac = Ftactic.run ftac (fun ans -> r := Some ans; Proofview.tclUNIT ()) in
+  let tac = Proofview.V82.of_tactic tac in
+  let { sigma = sigma } = tac gl in
+  let ans = match !r with
+  | None -> assert false (** If the tactic failed we should not reach this point *)
+  | Some ans -> ans
+  in
+  (sigma, ans)
+
+let interp_wit wit ist gl x = 
+  let globarg = in_gen (glbwit wit) x in
+  let arg = interp_genarg ist globarg in
+  let (sigma, arg) = of_ftactic arg gl in
+  sigma, Value.cast (topwit wit) arg
+let interp_constr = interp_wit wit_constr
+let interp_open_constr ist gl gc =
+  interp_wit wit_open_constr ist gl gc
+let pf_intern_term ist gl (_, c) = glob_constr ist (pf_env gl) c
+let interp_term ist gl (_, c) = (interp_open_constr ist gl c)
+let pr_ssrterm _ _ _ = pr_term
+let input_ssrtermkind strm = match Compat.get_tok (stream_nth 0 strm) with
+  | Tok.KEYWORD "(" -> '('
+  | Tok.KEYWORD "@" -> '@'
+  | _ -> ' '
+let ssrtermkind = Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind
+
+let interp_ssrterm _ gl t = Tacmach.project gl, t
+
+ARGUMENT EXTEND cpattern
+     PRINTED BY pr_ssrterm
+     INTERPRETED BY interp_ssrterm
+     GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm
+     RAW_PRINTED BY pr_ssrterm
+     GLOB_PRINTED BY pr_ssrterm
+| [ "Qed" constr(c) ] -> [ mk_lterm c ]
+END
+
+let (!@) = Compat.to_coqloc
+
+GEXTEND Gram
+  GLOBAL: cpattern;
+  cpattern: [[ k = ssrtermkind; c = constr ->
+    let pattern = mk_term k c in
+    if loc_ofCG pattern <> !@loc && k = '(' then mk_term 'x' c else pattern ]];
+END
+
+ARGUMENT EXTEND lcpattern
+     TYPED AS cpattern
+     PRINTED BY pr_ssrterm
+     INTERPRETED BY interp_ssrterm
+     GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm
+     RAW_PRINTED BY pr_ssrterm
+     GLOB_PRINTED BY pr_ssrterm
+| [ "Qed" lconstr(c) ] -> [ mk_lterm c ]
+END
+
+GEXTEND Gram
+  GLOBAL: lcpattern;
+  lcpattern: [[ k = ssrtermkind; c = lconstr ->
+    let pattern = mk_term k c in
+    if loc_ofCG pattern <> !@loc && k = '(' then mk_term 'x' c else pattern ]];
+END
+
+let thin id sigma goal =
+  let ids = Id.Set.singleton id in
+  let env = Goal.V82.env sigma goal in
+  let cl = Goal.V82.concl sigma goal in
+  let evdref = ref (Evd.clear_metas sigma) in
+  let ans =
+    try Some (Evarutil.clear_hyps_in_evi env evdref (Environ.named_context_val env) cl ids)
+    with Evarutil.ClearDependencyError _ -> None
+  in
+  match ans with
+  | None -> sigma
+  | Some (hyps, concl) ->
+    let sigma = !evdref in
+    let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in
+    let sigma = Goal.V82.partial_solution_to sigma goal gl ev in
+    sigma
+
+let pr_ist { lfun= lfun } =
+  prlist_with_sep spc
+    (fun (id, Geninterp.Val.Dyn(ty,_)) ->
+        pr_id id ++ str":" ++ Geninterp.Val.pr ty) (Id.Map.bindings lfun)
+
+let interp_pattern ?wit_ssrpatternarg ist gl red redty =
+  pp(lazy(str"interpreting: " ++ pr_pattern red));
+  pp(lazy(str" in ist: " ++ pr_ist ist));
+  let xInT x y = X_In_T(x,y) and inXInT x y = In_X_In_T(x,y) in
+  let inT x = In_T x and eInXInT e x t = E_In_X_In_T(e,x,t) in
+  let eAsXInT e x t = E_As_X_In_T(e,x,t) in
+  let mkG ?(k=' ') x = k,(x,None) in
+  let decode ist t ?reccall f g =
+    try match (pf_intern_term ist gl t) with
+    | GCast(_,GHole _,CastConv(GLambda(_,Name x,_,_,c))) -> f x (' ',(c,None))
+    | GVar(_,id)
+      when Id.Map.mem id ist.lfun &&
+           not(Option.is_empty reccall) &&
+           not(Option.is_empty wit_ssrpatternarg) ->
+        let v = Id.Map.find id ist.lfun in
+        Option.get reccall
+          (Value.cast (topwit (Option.get wit_ssrpatternarg)) v)
+    | it -> g t with e when CErrors.noncritical e -> g t in
+  let decodeG t f g = decode ist (mkG t) f g in
+  let bad_enc id _ = CErrors.anomaly (str"bad encoding for pattern "++str id) in
+  let cleanup_XinE h x rp sigma =
+    let h_k = match kind_of_term h with Evar (k,_) -> k | _ -> assert false in
+    let to_clean, update = (* handle rename if x is already used *)
+      let ctx = pf_hyps gl in
+      let len = Context.Named.length ctx in
+      let name = ref None in
+      try ignore(Context.Named.lookup x ctx); (name, fun k ->
+        if !name = None then
+        let nctx = Evd.evar_context (Evd.find sigma k) in
+        let nlen = Context.Named.length nctx in
+        if nlen > len then begin
+          name := Some (Context.Named.Declaration.get_id (List.nth nctx (nlen - len - 1)))
+        end)
+      with Not_found -> ref (Some x), fun _ -> () in
+    let sigma0 = project gl in
+    let new_evars =
+      let rec aux acc t = match kind_of_term t with
+      | Evar (k,_) ->
+          if k = h_k || List.mem k acc || Evd.mem sigma0 k then acc else
+          (update k; k::acc)
+      | _ -> fold_constr aux acc t in 
+      aux [] (Evarutil.nf_evar sigma rp) in
+    let sigma = 
+      List.fold_left (fun sigma e ->
+        if Evd.is_defined sigma e then sigma else (* clear may be recursive *)
+        if Option.is_empty !to_clean then sigma else
+        let name = Option.get !to_clean in
+        pp(lazy(pr_id name));
+        thin name sigma e)
+      sigma new_evars in
+    sigma in
+  let red = let rec decode_red (ist,red) = match red with
+    | T(k,(GCast (_,GHole _,(CastConv(GLambda (_,Name id,_,_,t)))),None))
+        when let id = string_of_id id in let len = String.length id in
+        (len > 8 && String.sub id 0 8 = "_ssrpat_") ->
+        let id = string_of_id id in let len = String.length id in
+        (match String.sub id 8 (len - 8), t with
+        | "In", GApp(_, _, [t]) -> decodeG t xInT (fun x -> T x)
+        | "In", GApp(_, _, [e; t]) -> decodeG t (eInXInT (mkG e)) (bad_enc id)
+        | "In", GApp(_, _, [e; t; e_in_t]) ->
+            decodeG t (eInXInT (mkG e))
+              (fun _ -> decodeG e_in_t xInT (fun _ -> assert false))
+        | "As", GApp(_, _, [e; t]) -> decodeG t (eAsXInT (mkG e)) (bad_enc id)
+        | _ -> bad_enc id ())
+    | T t -> decode ist ~reccall:decode_red t xInT (fun x -> T x)
+    | In_T t -> decode ist t inXInT inT
+    | X_In_T (e,t) -> decode ist t (eInXInT e) (fun x -> xInT (id_of_Cterm e) x)
+    | In_X_In_T (e,t) -> inXInT (id_of_Cterm e) t
+    | E_In_X_In_T (e,x,rp) -> eInXInT e (id_of_Cterm x) rp
+    | E_As_X_In_T (e,x,rp) -> eAsXInT e (id_of_Cterm x) rp in
+    decode_red (ist,red) in
+  pp(lazy(str"decoded as: " ++ pr_pattern_w_ids red));
+  let red = match redty with None -> red | Some ty -> let ty = ' ', ty in
+  match red with
+  | T t -> T (combineCG t ty (mkCCast (loc_ofCG t)) mkRCast)
+  | X_In_T (x,t) ->
+      let ty = pf_intern_term ist gl ty in
+      E_As_X_In_T (mkG (mkRCast mkRHole ty), x, t)
+  | E_In_X_In_T (e,x,t) ->
+      let ty = mkG (pf_intern_term ist gl ty) in
+      E_In_X_In_T (combineCG e ty (mkCCast (loc_ofCG t)) mkRCast, x, t)
+  | E_As_X_In_T (e,x,t) ->
+      let ty = mkG (pf_intern_term ist gl ty) in
+      E_As_X_In_T (combineCG e ty (mkCCast (loc_ofCG t)) mkRCast, x, t)
+  | red -> red in
+  pp(lazy(str"typed as: " ++ pr_pattern_w_ids red));
+  let mkXLetIn loc x (a,(g,c)) = match c with
+  | Some b -> a,(g,Some (mkCLetIn loc x (mkCHole loc) b))
+  | None -> a,(GLetIn (loc,x,(GHole (loc, BinderType x, IntroAnonymous, None)), g), None) in
+  match red with
+  | T t -> let sigma, t = interp_term ist gl t in sigma, T t
+  | In_T t -> let sigma, t = interp_term ist gl t in sigma, In_T t
+  | X_In_T (x, rp) | In_X_In_T (x, rp) ->
+    let mk x p = match red with X_In_T _ -> X_In_T(x,p) | _ -> In_X_In_T(x,p) in
+    let rp = mkXLetIn dummy_loc (Name x) rp in
+    let sigma, rp = interp_term ist gl rp in
+    let _, h, _, rp = destLetIn rp in
+    let sigma = cleanup_XinE h x rp sigma in
+    let rp = subst1 h (Evarutil.nf_evar sigma rp) in
+    sigma, mk h rp
+  | E_In_X_In_T(e, x, rp) | E_As_X_In_T (e, x, rp) ->
+    let mk e x p =
+      match red with E_In_X_In_T _ ->E_In_X_In_T(e,x,p)|_->E_As_X_In_T(e,x,p) in
+    let rp = mkXLetIn dummy_loc (Name x) rp in
+    let sigma, rp = interp_term ist gl rp in
+    let _, h, _, rp = destLetIn rp in
+    let sigma = cleanup_XinE h x rp sigma in
+    let rp = subst1 h (Evarutil.nf_evar sigma rp) in
+    let sigma, e = interp_term ist (re_sig (sig_it gl) sigma) e in
+    sigma, mk e h rp
+;;
+let interp_cpattern ist gl red redty = interp_pattern ist gl (T red) redty;;
+let interp_rpattern ~wit_ssrpatternarg ist gl red = interp_pattern ~wit_ssrpatternarg ist gl red None;;
+
+let id_of_pattern = function
+  | _, T t -> (match kind_of_term t with Var id -> Some id | _ -> None)
+  | _ -> None
+
+(* The full occurrence set *)
+let noindex = Some(false,[])
+
+(* calls do_subst on every sub-term identified by (pattern,occ) *)
+let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst =
+  let fs sigma x = Reductionops.nf_evar sigma x in
+  let pop_evar sigma e p =
+    let { Evd.evar_body = e_body } as e_def = Evd.find sigma e in
+    let e_body = match e_body with Evar_defined c -> c
+    | _ -> errorstrm (str "Matching the pattern " ++ pr_constr p ++
+          str " did not instantiate ?" ++ int (Evar.repr e) ++ spc () ++
+          str "Does the variable bound by the \"in\" construct occur "++
+          str "in the pattern?") in
+    let sigma = 
+      Evd.add (Evd.remove sigma e) e {e_def with Evd.evar_body = Evar_empty} in
+    sigma, e_body in
+  let ex_value hole =
+    match kind_of_term hole with Evar (e,_) -> e | _ -> assert false in
+  let mk_upat_for ?hack env sigma0 (sigma, t) ?(p=t) ok =
+    let sigma,pat= mk_tpattern ?hack env sigma0 (sigma,p) ok L2R (fs sigma t) in
+    sigma, [pat] in
+  match pattern with
+  | None -> do_subst env0 concl0 concl0 1
+  | Some (sigma, (T rp | In_T rp)) -> 
+    let rp = fs sigma rp in
+    let ise = create_evar_defs sigma in
+    let occ = match pattern with Some (_, T _) -> occ | _ -> noindex in
+    let rp = mk_upat_for env0 sigma0 (ise, rp) all_ok in
+    let find_T, end_T = mk_tpattern_matcher ?raise_NoMatch sigma0 occ rp in
+    let concl = find_T env0 concl0 1 do_subst in
+    let _ = end_T () in
+    concl
+  | Some (sigma, (X_In_T (hole, p) | In_X_In_T (hole, p))) ->
+    let p = fs sigma p in
+    let occ = match pattern with Some (_, X_In_T _) -> occ | _ -> noindex in
+    let ex = ex_value hole in
+    let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in
+    let find_T, end_T = mk_tpattern_matcher sigma0 noindex rp in
+    (* we start from sigma, so hole is considered a rigid head *)
+    let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in
+    let find_X, end_X = mk_tpattern_matcher ?raise_NoMatch sigma occ holep in
+    let concl = find_T env0 concl0 1 (fun env c _ h ->
+      let p_sigma = unify_HO env (create_evar_defs sigma) c p in
+      let sigma, e_body = pop_evar p_sigma ex p in
+      fs p_sigma (find_X env (fs sigma p) h 
+        (fun env _ -> do_subst env e_body))) in
+    let _ = end_X () in let _ = end_T () in 
+    concl
+  | Some (sigma, E_In_X_In_T (e, hole, p)) ->
+    let p, e = fs sigma p, fs sigma e in
+    let ex = ex_value hole in
+    let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in
+    let find_T, end_T = mk_tpattern_matcher sigma0 noindex rp in
+    let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in
+    let find_X, end_X = mk_tpattern_matcher sigma noindex holep in
+    let re = mk_upat_for env0 sigma0 (sigma, e) all_ok in
+    let find_E, end_E = mk_tpattern_matcher ?raise_NoMatch sigma0 occ re in
+    let concl = find_T env0 concl0 1 (fun env c _ h ->
+      let p_sigma = unify_HO env (create_evar_defs sigma) c p in
+      let sigma, e_body = pop_evar p_sigma ex p in
+      fs p_sigma (find_X env (fs sigma p) h (fun env c _ h ->
+        find_E env e_body h do_subst))) in
+    let _ = end_E () in let _ = end_X () in let _ = end_T () in
+    concl
+  | Some (sigma, E_As_X_In_T (e, hole, p)) ->
+    let p, e = fs sigma p, fs sigma e in
+    let ex = ex_value hole in
+    let rp = 
+      let e_sigma = unify_HO env0 sigma hole e in
+      e_sigma, fs e_sigma p in
+    let rp = mk_upat_for ~hack:true env0 sigma0 rp all_ok in
+    let find_TE, end_TE = mk_tpattern_matcher sigma0 noindex rp in
+    let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in
+    let find_X, end_X = mk_tpattern_matcher sigma occ holep in
+    let concl = find_TE env0 concl0 1 (fun env c _ h ->
+      let p_sigma = unify_HO env (create_evar_defs sigma) c p in
+      let sigma, e_body = pop_evar p_sigma ex p in
+      fs p_sigma (find_X env (fs sigma p) h (fun env c _ h ->
+        let e_sigma = unify_HO env sigma e_body e in
+        let e_body = fs e_sigma e in
+        do_subst env e_body e_body h))) in
+    let _ = end_X () in let _ = end_TE () in
+    concl
+;;
+
+let redex_of_pattern ?(resolve_typeclasses=false) env (sigma, p) =
+  let e = match p with
+  | In_T _ | In_X_In_T _ -> CErrors.anomaly (str"pattern without redex")
+  | T e | X_In_T (e, _) | E_As_X_In_T (e, _, _) | E_In_X_In_T (e, _, _) -> e in
+  let sigma =
+    if not resolve_typeclasses then sigma
+    else Typeclasses.resolve_typeclasses ~fail:false env sigma in
+  Reductionops.nf_evar sigma e, Evd.evar_universe_context sigma
+
+let fill_occ_pattern ?raise_NoMatch env sigma cl pat occ h =
+  let do_make_rel, occ =
+    if occ = Some(true,[]) then false, Some(false,[1]) else true, occ in
+  let find_R, conclude =
+    let r = ref None in
+    (fun env c _ h' ->
+       do_once r (fun () -> c, Evd.empty_evar_universe_context);
+       if do_make_rel then mkRel (h'+h-1) else c),
+    (fun _ -> if !r = None then redex_of_pattern env pat else assert_done r) in
+  let cl = eval_pattern ?raise_NoMatch env sigma cl (Some pat) occ find_R in
+  let e = conclude cl in
+  e, cl
+;;
+
+(* clenup interface for external use *)
+let mk_tpattern ?p_origin env sigma0 sigma_t f dir c = 
+  mk_tpattern ?p_origin env sigma0 sigma_t f dir c
+;;
+
+let pf_fill_occ env concl occ sigma0 p (sigma, t) ok h =
+ let ise = create_evar_defs sigma in
+ let ise, u = mk_tpattern env sigma0 (ise,t) ok L2R p in
+ let find_U, end_U =
+   mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[u]) in
+ let concl = find_U env concl h (fun _ _ _ -> mkRel) in
+ let rdx, _, (sigma, uc, p) = end_U () in
+ sigma, uc, p, concl, rdx
+
+let fill_occ_term env cl occ sigma0 (sigma, t) =
+  try
+    let sigma',uc,t',cl,_= pf_fill_occ env cl occ sigma0 t (sigma, t) all_ok 1 in
+    if sigma' != sigma0 then CErrors.error "matching impacts evars"
+    else cl, (Evd.merge_universe_context sigma' uc, t')
+  with NoMatch -> try
+    let sigma', uc, t' =
+      unif_end env sigma0 (create_evar_defs sigma) t (fun _ -> true) in
+    if sigma' != sigma0 then raise NoMatch
+    else cl, (Evd.merge_universe_context sigma' uc, t')
+  with _ ->
+    errorstrm (str "partial term " ++ pr_constr_pat t
+            ++ str " does not match any subterm of the goal")
+
+let pf_fill_occ_term gl occ t =
+  let sigma0 = project gl and env = pf_env gl and concl = pf_concl gl in
+  let cl,(_,t) = fill_occ_term env concl occ sigma0 t in
+  cl, t
+
+let cpattern_of_id id = ' ', (GRef (dummy_loc, VarRef  id, None), None)
+
+let is_wildcard = function
+  | _,(_,Some (CHole _)|GHole _,None) -> true
+  | _ -> false
+
+(* "ssrpattern" *)
+let pr_ssrpatternarg _ _ _ (_,cpat) = pr_rpattern cpat
+let pr_ssrpatternarg_glob _ _ _ cpat = pr_rpattern cpat
+let interp_ssrpatternarg ist gl p = project gl, (ist, p)
+
+ARGUMENT EXTEND ssrpatternarg
+  PRINTED BY pr_ssrpatternarg
+  INTERPRETED BY interp_ssrpatternarg
+  GLOBALIZED BY glob_rpattern
+  RAW_PRINTED BY pr_ssrpatternarg_glob
+  GLOB_PRINTED BY pr_ssrpatternarg_glob
+| [ rpattern(pat) ] -> [ pat ]
+END
+  
+let pf_merge_uc uc gl =
+  re_sig (sig_it gl) (Evd.merge_universe_context (project gl) uc)
+
+let pf_unsafe_merge_uc uc gl =
+  re_sig (sig_it gl) (Evd.set_universe_context (project gl) uc)
+
+let interp_rpattern ist gl red = interp_rpattern ~wit_ssrpatternarg ist gl red
+
+let ssrpatterntac _ist (arg_ist,arg) gl =
+  let pat = interp_rpattern arg_ist gl arg in
+  let sigma0 = project gl in
+  let concl0 = pf_concl gl in
+  let (t, uc), concl_x =
+    fill_occ_pattern (Global.env()) sigma0 concl0 pat noindex 1 in
+  let gl, tty = pf_type_of gl t in
+  let concl = mkLetIn (Name (id_of_string "selected"), t, tty, concl_x) in
+  Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl
+
+(* Register "ssrpattern" tactic *)
+let () =
+  let mltac _ ist =
+    let arg =
+      let v = Id.Map.find (Names.Id.of_string "pattern") ist.lfun in
+      Value.cast (topwit wit_ssrpatternarg) v in
+    Proofview.V82.tactic (ssrpatterntac ist arg) in
+  let name = { mltac_plugin = "ssrmatching_plugin"; mltac_tactic = "ssrpattern"; } in
+  let () = Tacenv.register_ml_tactic name [|mltac|] in
+  let tac =
+    TacFun ([Some (Id.of_string "pattern")],
+      TacML (Loc.ghost, { mltac_name = name; mltac_index = 0 }, [])) in
+  let obj () =
+    Tacenv.register_ltac true false (Id.of_string "ssrpattern") tac in
+  Mltop.declare_cache_obj obj "ssrmatching_plugin"
+
+let ssrinstancesof ist arg gl =
+  let ok rhs lhs ise = true in
+(*   not (Term.eq_constr lhs (Evarutil.nf_evar ise rhs)) in *)
+  let env, sigma, concl = pf_env gl, project gl, pf_concl gl in
+  let sigma0, cpat = interp_cpattern ist gl arg None in
+  let pat = match cpat with T x -> x | _ -> errorstrm (str"Not supported") in
+  let etpat, tpat = mk_tpattern env sigma (sigma0,pat) (ok pat) L2R pat in
+  let find, conclude =
+    mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true
+      sigma None (etpat,[tpat]) in
+  let print env p c _ = ppnl (hov 1 (str"instance:" ++ spc() ++ pr_constr p ++ spc() ++ str "matches:" ++ spc() ++ pr_constr c)); c in
+  ppnl (str"BEGIN INSTANCES");
+  try
+    while true do
+      ignore(find env concl 1 ~k:print)
+    done; raise NoMatch
+  with NoMatch -> ppnl (str"END INSTANCES"); tclIDTAC gl
+
+TACTIC EXTEND ssrinstoftpat
+| [ "ssrinstancesoftpat" cpattern(arg) ] -> [ Proofview.V82.tactic (ssrinstancesof ist arg) ]
+END
+
+(* We wipe out all the keywords generated by the grammar rules we defined. *)
+(* The user is supposed to Require Import ssreflect or Require ssreflect   *)
+(* and Import ssreflect.SsrSyntax to obtain these keywords and as a         *)
+(* consequence the extended ssreflect grammar.                             *)
+let () = CLexer.unfreeze frozen_lexer ;;
+
+(* vim: set filetype=ocaml foldmethod=marker: *)
diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli
new file mode 100644
index 00000000..288a04e6
--- /dev/null
+++ b/plugins/ssrmatching/ssrmatching.mli
@@ -0,0 +1,241 @@
+(* (c) Copyright 2006-2015 Microsoft Corporation and Inria.                  *)
+(* Distributed under the terms of CeCILL-B.                                  *)
+
+open Genarg
+open Tacexpr
+open Environ
+open Tacmach
+open Evd
+open Proof_type
+open Term
+
+(** ******** Small Scale Reflection pattern matching facilities ************* *)
+
+(** Pattern parsing *)
+
+(** The type of context patterns, the patterns of the [set] tactic and 
+    [:] tactical. These are patterns that identify a precise subterm. *)
+type cpattern
+val pr_cpattern : cpattern -> Pp.std_ppcmds
+
+(** CS cpattern: (f _), (X in t), (t in X in t), (t as X in t) *)
+val cpattern         : cpattern Pcoq.Gram.entry
+val wit_cpattern     : cpattern uniform_genarg_type
+
+(** OS cpattern: f _, (X in t), (t in X in t), (t as X in t) *)
+val lcpattern         : cpattern Pcoq.Gram.entry
+val wit_lcpattern     : cpattern uniform_genarg_type
+
+(** The type of rewrite patterns, the patterns of the [rewrite] tactic.
+    These patterns also include patterns that identify all the subterms
+    of a context (i.e. "in" prefix) *)
+type rpattern
+val pr_rpattern : rpattern -> Pp.std_ppcmds
+
+(** OS rpattern: f _, in t, X in t, in X in t, t in X in t, t as X in t *)
+val rpattern         : rpattern Pcoq.Gram.entry
+val wit_rpattern     : rpattern uniform_genarg_type
+
+(** Pattern interpretation and matching *)
+
+exception NoMatch
+exception NoProgress
+
+(** AST for [rpattern] (and consequently [cpattern]) *)
+type ('ident, 'term) ssrpattern =
+  | T of 'term
+  | In_T of 'term
+  | X_In_T of 'ident * 'term
+  | In_X_In_T of 'ident * 'term
+  | E_In_X_In_T of 'term * 'ident * 'term
+  | E_As_X_In_T of 'term * 'ident * 'term
+
+type pattern = evar_map * (constr, constr) ssrpattern
+val pp_pattern : pattern -> Pp.std_ppcmds
+
+(** Extracts the redex and applies to it the substitution part of the pattern.
+  @raise Anomaly if called on [In_T] or [In_X_In_T] *)
+val redex_of_pattern :
+  ?resolve_typeclasses:bool -> env -> pattern ->
+     constr Evd.in_evar_universe_context
+
+(** [interp_rpattern ise gl rpat] "internalizes" and "interprets" [rpat]
+    in the current [Ltac] interpretation signature [ise] and tactic input [gl]*)
+val interp_rpattern :
+  Tacinterp.interp_sign -> goal sigma ->
+  rpattern ->
+    pattern
+
+(** [interp_cpattern ise gl cpat ty] "internalizes" and "interprets" [cpat]
+    in the current [Ltac] interpretation signature [ise] and tactic input [gl].
+    [ty] is an optional type for the redex of [cpat] *)
+val interp_cpattern :
+  Tacinterp.interp_sign -> goal sigma ->
+  cpattern -> glob_constr_and_expr option ->
+    pattern
+
+(** The set of occurrences to be matched. The boolean is set to true
+ *  to signal the complement of this set (i.e. {-1 3}) *)
+type occ = (bool * int list) option
+
+(** [subst e p t i]. [i] is the number of binders
+    traversed so far, [p] the term from the pattern, [t] the matched one *)
+type subst = env -> constr -> constr -> int -> constr
+
+(** [eval_pattern b env sigma t pat occ subst] maps [t] calling [subst] on every
+    [occ] occurrence of [pat]. The [int] argument is the number of 
+    binders traversed. If [pat] is [None] then then subst is called on [t].
+    [t] must live in [env] and [sigma], [pat] must have been interpreted in 
+    (an extension of) [sigma]. 
+  @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false])
+  @return [t] where all [occ] occurrences of [pat] have been mapped using
+    [subst] *)
+val eval_pattern :
+  ?raise_NoMatch:bool ->
+  env -> evar_map -> constr ->
+  pattern option -> occ -> subst ->
+    constr
+
+(** [fill_occ_pattern b env sigma t pat occ h] is a simplified version of 
+    [eval_pattern]. 
+    It replaces all [occ] occurrences of [pat] in [t] with Rel [h]. 
+    [t] must live in [env] and [sigma], [pat] must have been interpreted in 
+    (an extension of) [sigma]. 
+  @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false]) 
+  @return the instance of the redex of [pat] that was matched and [t]
+    transformed as described above. *)
+val fill_occ_pattern :
+  ?raise_NoMatch:bool ->
+  env -> evar_map -> constr ->
+  pattern -> occ -> int ->
+    constr Evd.in_evar_universe_context * constr
+
+(** *************************** Low level APIs ****************************** *)
+
+(* The primitive matching facility. It matches of a term with holes, like 
+   the T pattern above, and calls a continuation on its occurrences. *)
+
+type ssrdir = L2R | R2L
+val pr_dir_side : ssrdir -> Pp.std_ppcmds
+
+(** a pattern for a term with wildcards *)
+type tpattern
+
+(** [mk_tpattern env sigma0 sigma_p ok p_origin dir t] compiles a term [t] 
+    living in [env] [sigma] (an extension of [sigma0]) intro a [tpattern].
+    The [tpattern] can hold a (proof) term [p] and a diction [dir]. The [ok]
+    callback is used to filter occurrences.
+  @return the compiled [tpattern] and its [evar_map]
+  @raise UserEerror is the pattern is a wildcard *)
+val mk_tpattern :
+  ?p_origin:ssrdir * constr ->
+  env -> evar_map ->
+  evar_map * constr ->
+  (constr -> evar_map -> bool) ->
+  ssrdir -> constr ->
+    evar_map * tpattern
+
+(** [findP env t i k] is a stateful function that finds the next occurrence 
+    of a tpattern and calls the callback [k] to map the subterm matched. 
+    The [int] argument passed to [k] is the number of binders traversed so far 
+    plus the initial value [i]. 
+  @return [t] where the subterms identified by the selected occurrences of 
+    the patter have been mapped using [k]
+  @raise NoMatch if the raise_NoMatch flag given to [mk_tpattern_matcher] is
+    [true] and if the pattern did not match 
+  @raise UserEerror if the raise_NoMatch flag given to [mk_tpattern_matcher] is
+    [false] and if the pattern did not match *)
+type find_P =
+  env -> constr -> int -> k:subst -> constr
+
+(** [conclude ()] asserts that all mentioned ocurrences have been visited.
+  @return the instance of the pattern, the evarmap after the pattern
+    instantiation, the proof term and the ssrdit stored in the tpattern
+  @raise UserEerror if too many occurrences were specified *)
+type conclude =
+  unit -> constr * ssrdir * (evar_map * Evd.evar_universe_context * constr)
+
+(** [mk_tpattern_matcher b o sigma0 occ sigma_tplist] creates a pair 
+    a function [find_P] and [conclude] with the behaviour explained above.
+    The flag [b] (default [false]) changes the error reporting behaviour
+    of [find_P] if none of the [tpattern] matches. The argument [o] can
+    be passed to tune the [UserError] eventually raised (useful if the 
+    pattern is coming from the LHS/RHS of an equation) *)
+val mk_tpattern_matcher :
+  ?all_instances:bool ->
+  ?raise_NoMatch:bool ->
+  ?upats_origin:ssrdir * constr ->
+  evar_map -> occ -> evar_map * tpattern list ->
+    find_P * conclude
+
+(** Example of [mk_tpattern_matcher] to implement 
+    [rewrite \{occ\}\[in t\]rules].
+    It first matches "in t" (called [pat]), then in all matched subterms 
+    it matches the LHS of the rules using [find_R].
+    [concl0] is the initial goal, [concl] will be the goal where some terms
+    are replaced by a De Bruijn index. The [rw_progress] extra check
+    selects only occurrences that are not rewritten to themselves (e.g.
+    an occurrence "x + x" rewritten with the commutativity law of addition 
+    is skipped) {[
+  let find_R, conclude = match pat with
+  | Some (_, In_T _) ->
+      let aux (sigma, pats) (d, r, lhs, rhs) =
+        let sigma, pat = 
+          mk_tpattern env0 sigma0 (sigma, r) (rw_progress rhs) d lhs in
+        sigma, pats @ [pat] in
+      let rpats = List.fold_left aux (r_sigma, []) rules in
+      let find_R, end_R = mk_tpattern_matcher sigma0 occ rpats in
+      find_R ~k:(fun _ _ h -> mkRel h), 
+      fun cl -> let rdx, d, r = end_R () in (d,r),rdx
+  | _ -> ... in
+  let concl = eval_pattern env0 sigma0 concl0 pat occ find_R in
+  let (d, r), rdx = conclude concl in ]} *)
+
+(* convenience shortcut: [pf_fill_occ_term gl occ (sigma,t)] returns
+ * the conclusion of [gl] where [occ] occurrences of [t] have been replaced
+ * by [Rel 1] and the instance of [t] *)
+val pf_fill_occ_term : goal sigma -> occ -> evar_map * constr -> constr * constr
+
+(* It may be handy to inject a simple term into the first form of cpattern *)
+val cpattern_of_term : char * glob_constr_and_expr -> cpattern
+
+(** Helpers to make stateful closures. Example: a [find_P] function may be 
+    called many times, but the pattern instantiation phase is performed only the
+    first time. The corresponding [conclude] has to return the instantiated
+    pattern redex. Since it is up to [find_P] to raise [NoMatch] if the pattern
+    has no instance, [conclude] considers it an anomaly if the pattern did
+    not match *)
+
+(** [do_once r f] calls [f] and updates the ref only once *)
+val do_once : 'a option ref -> (unit -> 'a) -> unit
+(** [assert_done r] return the content of r. @raise Anomaly is r is [None] *)
+val assert_done : 'a option ref -> 'a
+
+(** Very low level APIs.
+    these are calls to evarconv's [the_conv_x] followed by
+    [solve_unif_constraints_with_heuristics] and [resolve_typeclasses].
+    In case of failure they raise [NoMatch] *)
+
+val unify_HO : env -> evar_map -> constr -> constr -> evar_map
+val pf_unify_HO : goal sigma -> constr -> constr -> goal sigma
+
+(** Some more low level functions needed to implement the full SSR language
+    on top of the former APIs *)
+val tag_of_cpattern : cpattern -> char
+val loc_of_cpattern : cpattern -> Loc.t
+val id_of_pattern : pattern -> Names.variable option
+val is_wildcard : cpattern -> bool
+val cpattern_of_id : Names.variable -> cpattern
+val cpattern_of_id : Names.variable -> cpattern
+val pr_constr_pat : constr -> Pp.std_ppcmds
+val pf_merge_uc : Evd.evar_universe_context -> goal Evd.sigma -> goal Evd.sigma
+val pf_unsafe_merge_uc : Evd.evar_universe_context -> goal Evd.sigma -> goal Evd.sigma
+
+(* One can also "Set SsrMatchingDebug" from a .v *)
+val debug : bool -> unit
+
+(* One should delimit a snippet with "Set SsrMatchingProfiling" and
+ * "Unset SsrMatchingProfiling" to get timings *)
+val profile : bool -> unit
+
+(* eof *)
diff --git a/plugins/ssrmatching/ssrmatching.v b/plugins/ssrmatching/ssrmatching.v
new file mode 100644
index 00000000..829ee05e
--- /dev/null
+++ b/plugins/ssrmatching/ssrmatching.v
@@ -0,0 +1,26 @@
+(* (c) Copyright 2006-2015 Microsoft Corporation and Inria.                  *)
+(* Distributed under the terms of CeCILL-B.                                  *)
+Declare ML Module "ssrmatching_plugin".
+
+Module SsrMatchingSyntax.
+
+(* Reserve the notation for rewrite patterns so that the user is not allowed  *)
+(* to declare it at a different level.                                        *)
+Reserved Notation "( a 'in' b )"        (at level 0).
+Reserved Notation "( a 'as' b )"        (at level 0).
+Reserved Notation "( a 'in' b 'in' c )" (at level 0).
+Reserved Notation "( a 'as' b 'in' c )" (at level 0).
+
+(* Notation to define shortcuts for the "X in t" part of a pattern.           *)
+Notation "( X 'in' t )" := (_ : fun X => t) : ssrpatternscope.
+Delimit Scope ssrpatternscope with pattern.
+
+(* Some shortcuts for recurrent "X in t" parts.                               *)
+Notation RHS := (X in _ = X)%pattern.
+Notation LHS := (X in X = _)%pattern.
+
+End SsrMatchingSyntax.
+
+Export SsrMatchingSyntax.
+
+Tactic Notation "ssrpattern" ssrpatternarg(p) := ssrpattern p .
diff --git a/plugins/ssrmatching/ssrmatching_plugin.mlpack b/plugins/ssrmatching/ssrmatching_plugin.mlpack
new file mode 100644
index 00000000..5fb1f156
--- /dev/null
+++ b/plugins/ssrmatching/ssrmatching_plugin.mlpack
@@ -0,0 +1 @@
+Ssrmatching
diff --git a/plugins/ssrmatching/vo.itarget b/plugins/ssrmatching/vo.itarget
new file mode 100644
index 00000000..b0eb3883
--- /dev/null
+++ b/plugins/ssrmatching/vo.itarget
@@ -0,0 +1 @@
+ssrmatching.vo
diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml
index 67c9dd0a..e18d19ce 100644
--- a/plugins/syntax/ascii_syntax.ml
+++ b/plugins/syntax/ascii_syntax.ml
@@ -6,8 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
+(* Poor's man DECLARE PLUGIN *)
+let __coq_plugin_name = "ascii_syntax_plugin"
+let () = Mltop.add_known_module __coq_plugin_name
+
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Glob_term
diff --git a/plugins/syntax/ascii_syntax_plugin.mllib b/plugins/syntax/ascii_syntax_plugin.mllib
deleted file mode 100644
index b00f9250..00000000
--- a/plugins/syntax/ascii_syntax_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-Ascii_syntax
-Ascii_syntax_plugin_mod
diff --git a/plugins/syntax/ascii_syntax_plugin.mlpack b/plugins/syntax/ascii_syntax_plugin.mlpack
new file mode 100644
index 00000000..7b9213a0
--- /dev/null
+++ b/plugins/syntax/ascii_syntax_plugin.mlpack
@@ -0,0 +1 @@
+Ascii_syntax
diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml
index 5f44904c..a9eb126b 100644
--- a/plugins/syntax/nat_syntax.ml
+++ b/plugins/syntax/nat_syntax.ml
@@ -6,6 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(* Poor's man DECLARE PLUGIN *)
+let __coq_plugin_name = "nat_syntax_plugin"
+let () = Mltop.add_known_module __coq_plugin_name
+
 (* This file defines the printer for natural numbers in [nat] *)
 
 (*i*)
@@ -13,7 +17,7 @@ open Glob_term
 open Bigint
 open Coqlib
 open Pp
-open Errors
+open CErrors
 (*i*)
 
 (**********************************************************************)
@@ -22,14 +26,16 @@ open Errors
 
 let threshold = of_int 5000
 
+let warn_large_nat =
+  CWarnings.create ~name:"large-nat" ~category:"numbers"
+    (fun () -> 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 nat_of_int dloc n =
   if is_pos_or_zero n then begin
-      if less_than threshold n then
-	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).");
+      if less_than threshold n then warn_large_nat ();
       let ref_O = GRef (dloc, glob_O, None) in
       let ref_S = GRef (dloc, glob_S, None) in
       let rec mk_nat acc n =
diff --git a/plugins/syntax/nat_syntax_plugin.mllib b/plugins/syntax/nat_syntax_plugin.mllib
deleted file mode 100644
index 69b0cb20..00000000
--- a/plugins/syntax/nat_syntax_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-Nat_syntax
-Nat_syntax_plugin_mod
diff --git a/plugins/syntax/nat_syntax_plugin.mlpack b/plugins/syntax/nat_syntax_plugin.mlpack
new file mode 100644
index 00000000..39bdd62f
--- /dev/null
+++ b/plugins/syntax/nat_syntax_plugin.mlpack
@@ -0,0 +1 @@
+Nat_syntax
diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml
index fe9f1319..f65f9b79 100644
--- a/plugins/syntax/numbers_syntax.ml
+++ b/plugins/syntax/numbers_syntax.ml
@@ -6,6 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(* Poor's man DECLARE PLUGIN *)
+let __coq_plugin_name = "numbers_syntax_plugin"
+let () = Mltop.add_known_module __coq_plugin_name
+
 (* digit-based syntax for int31, bigN bigZ and bigQ *)
 
 open Bigint
@@ -96,7 +100,7 @@ let int31_of_pos_bigint dloc n =
   GApp (dloc, ref_construct, List.rev (args 31 n))
 
 let error_negative dloc =
-  Errors.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.")
+  CErrors.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
@@ -180,12 +184,12 @@ let bigN_of_pos_bigint dloc n =
   let word = word_of_pos_bigint dloc h n in
   let args =
     if h < n_inlined then [word]
-    else [Nat_syntax.nat_of_int dloc (of_int (h-n_inlined));word]
+    else [Nat_syntax_plugin.Nat_syntax.nat_of_int dloc (of_int (h-n_inlined));word]
   in
   GApp (dloc, ref_constructor, args)
 
 let bigN_error_negative dloc =
-  Errors.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.")
+  CErrors.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
diff --git a/plugins/syntax/numbers_syntax_plugin.mllib b/plugins/syntax/numbers_syntax_plugin.mllib
deleted file mode 100644
index ebc0bb20..00000000
--- a/plugins/syntax/numbers_syntax_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-Numbers_syntax
-Numbers_syntax_plugin_mod
diff --git a/plugins/syntax/numbers_syntax_plugin.mlpack b/plugins/syntax/numbers_syntax_plugin.mlpack
new file mode 100644
index 00000000..e48c00a0
--- /dev/null
+++ b/plugins/syntax/numbers_syntax_plugin.mlpack
@@ -0,0 +1 @@
+Numbers_syntax
diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml
index 05d73f9e..3ae2d45f 100644
--- a/plugins/syntax/r_syntax.ml
+++ b/plugins/syntax/r_syntax.ml
@@ -10,6 +10,10 @@ open Util
 open Names
 open Globnames
 
+(* Poor's man DECLARE PLUGIN *)
+let __coq_plugin_name = "r_syntax_plugin"
+let () = Mltop.add_known_module __coq_plugin_name
+
 exception Non_closed_number
 
 (**********************************************************************)
diff --git a/plugins/syntax/r_syntax_plugin.mllib b/plugins/syntax/r_syntax_plugin.mllib
deleted file mode 100644
index 5c173a14..00000000
--- a/plugins/syntax/r_syntax_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-R_syntax
-R_syntax_plugin_mod
diff --git a/plugins/syntax/r_syntax_plugin.mlpack b/plugins/syntax/r_syntax_plugin.mlpack
new file mode 100644
index 00000000..d4ee75ea
--- /dev/null
+++ b/plugins/syntax/r_syntax_plugin.mlpack
@@ -0,0 +1 @@
+R_syntax
diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml
index 2e696f39..de0fa77e 100644
--- a/plugins/syntax/string_syntax.ml
+++ b/plugins/syntax/string_syntax.ml
@@ -7,10 +7,14 @@
 (***********************************************************************)
 
 open Globnames
-open Ascii_syntax
+open Ascii_syntax_plugin.Ascii_syntax
 open Glob_term
 open Coqlib
 
+(* Poor's man DECLARE PLUGIN *)
+let __coq_plugin_name = "string_syntax_plugin"
+let () = Mltop.add_known_module __coq_plugin_name
+
 exception Non_closed_string
 
 (* make a string term from the string s *)
diff --git a/plugins/syntax/string_syntax_plugin.mllib b/plugins/syntax/string_syntax_plugin.mllib
deleted file mode 100644
index b108c9e0..00000000
--- a/plugins/syntax/string_syntax_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-String_syntax
-String_syntax_plugin_mod
diff --git a/plugins/syntax/string_syntax_plugin.mlpack b/plugins/syntax/string_syntax_plugin.mlpack
new file mode 100644
index 00000000..45d6e0fa
--- /dev/null
+++ b/plugins/syntax/string_syntax_plugin.mlpack
@@ -0,0 +1 @@
+String_syntax
diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml
index 53c1b5d7..60803a36 100644
--- a/plugins/syntax/z_syntax.ml
+++ b/plugins/syntax/z_syntax.ml
@@ -7,11 +7,15 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Bigint
 
+(* Poor's man DECLARE PLUGIN *)
+let __coq_plugin_name = "z_syntax_plugin"
+let () = Mltop.add_known_module __coq_plugin_name
+
 exception Non_closed_number
 
 (**********************************************************************)
diff --git a/plugins/syntax/z_syntax_plugin.mllib b/plugins/syntax/z_syntax_plugin.mllib
deleted file mode 100644
index 36d41acc..00000000
--- a/plugins/syntax/z_syntax_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-Z_syntax
-Z_syntax_plugin_mod
diff --git a/plugins/syntax/z_syntax_plugin.mlpack b/plugins/syntax/z_syntax_plugin.mlpack
new file mode 100644
index 00000000..411260c0
--- /dev/null
+++ b/plugins/syntax/z_syntax_plugin.mlpack
@@ -0,0 +1 @@
+Z_syntax
diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml
index ca1d0b7f..e18aece0 100644
--- a/pretyping/arguments_renaming.ml
+++ b/pretyping/arguments_renaming.ml
@@ -16,12 +16,12 @@ open Libobject
 (*i*)
 
 let name_table =
-  Summary.ref (Refmap.empty : Name.t list list Refmap.t)
+  Summary.ref (Refmap.empty : Name.t list Refmap.t)
     ~name:"rename-arguments"
 
 type req =
   | ReqLocal
-  | ReqGlobal of global_reference * Name.t list list
+  | ReqGlobal of global_reference * Name.t list
 
 let load_rename_args _ (_, (_, (r, names))) =
   name_table := Refmap.add r names !name_table
@@ -49,7 +49,7 @@ let discharge_rename_args = function
        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
+       let names' = var_names @ names in
        Some (ReqGlobal (c', names), (c', names'))
      with Not_found -> Some req)
   | _ -> None
@@ -83,7 +83,7 @@ let rec rename_prod c = function
       | _ -> c
         
 let rename_type ty ref =
-  try rename_prod ty (List.hd (arguments_names ref))
+  try rename_prod ty (arguments_names ref)
   with Not_found -> ty
 
 let rename_type_of_constant env c =
diff --git a/pretyping/arguments_renaming.mli b/pretyping/arguments_renaming.mli
index a3340550..e123e778 100644
--- a/pretyping/arguments_renaming.mli
+++ b/pretyping/arguments_renaming.mli
@@ -11,10 +11,10 @@ open Globnames
 open Environ
 open Term
 
-val rename_arguments : bool -> global_reference -> Name.t list list -> unit
+val rename_arguments : bool -> global_reference -> Name.t list -> unit
 
-(** [Not_found] is raised is no names are defined for [r] *)
-val arguments_names : global_reference -> Name.t list list
+(** [Not_found] is raised if no names are defined for [r] *)
+val arguments_names : global_reference -> Name.t list
 
 val rename_type_of_constant : env -> pconstant -> types
 val rename_type_of_inductive : env -> pinductive -> types
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 3d6fa38d..6e4d7270 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -7,13 +7,12 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
 open Term
 open Vars
-open Context
 open Termops
 open Namegen
 open Declarations
@@ -26,9 +25,12 @@ open Glob_ops
 open Retyping
 open Pretype_errors
 open Evarutil
+open Evardefine
 open Evarsolve
 open Evarconv
 open Evd
+open Sigma.Notations
+open Context.Rel.Declaration
 
 (* Pattern-matching errors *)
 
@@ -60,13 +62,15 @@ let error_wrong_numarg_constructor_loc loc env c n =
 let error_wrong_numarg_inductive_loc loc env c n =
   raise_pattern_matching_error (loc, env, Evd.empty, WrongNumargInductive(c,n))
 
-let rec list_try_compile f = function
-  | [a] -> f a
-  | [] -> anomaly (str "try_find_f")
+let list_try_compile f l =
+  let rec aux errors = function
+  | [] -> if errors = [] then anomaly (str "try_find_f") else iraise (List.last errors)
   | h::t ->
       try f h
-      with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _ ->
-	    list_try_compile f t
+      with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _ as e ->
+	    let e = CErrors.push e in
+	    aux (e::errors) t in
+  aux [] l
 
 let force_name =
   let nx = Name default_dependent_ident in function Anonymous -> nx | na -> na
@@ -131,7 +135,7 @@ 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
+  | Abstract of int * Context.Rel.Declaration.t
 
 type tomatch_stack = tomatch_status list
 
@@ -273,13 +277,13 @@ let inductive_template evdref env tmloc ind =
     | None -> fun _ -> (Loc.ghost, Evar_kinds.InternalHole) in
    let (_,evarl,_) =
     List.fold_right
-      (fun (na,b,ty) (subst,evarl,n) ->
-	match b with
-        | None ->
+      (fun decl (subst,evarl,n) ->
+	match decl with
+        | LocalAssum (na,ty) ->
 	    let ty' = substl subst ty in
 	    let e = e_new_evar env evdref ~src:(hole_source n) ty' in
 	    (e::subst,e::evarl,n+1)
-	| Some b ->
+	| LocalDef (na,b,ty) ->
 	    (substl subst b::subst,evarl,n+1))
       arsign ([],[],1) in
    applist (mkIndU indu,List.rev evarl)
@@ -307,15 +311,15 @@ let binding_vars_of_inductive = function
   | NotInd _ -> []
   | IsInd (_,IndType(_,realargs),_) -> List.filter isRel realargs
 
-let extract_inductive_data env sigma (_,b,t) =
-  match b with
-  | None ->
+let extract_inductive_data env sigma decl =
+  match decl with
+  | LocalAssum (_,t) ->
     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 _ ->
+  | LocalDef (_,_,t) ->
     (NotInd (None, t), [])
 
 let unify_tomatch_with_patterns evdref env loc typ pats realnames =
@@ -428,7 +432,7 @@ let remove_current_pattern eqn =
 let push_current_pattern (cur,ty) eqn =
   match eqn.patterns with
     | pat::pats ->
-        let rhs_env = push_rel (alias_of_pat pat,Some cur,ty) eqn.rhs.rhs_env in
+        let rhs_env = push_rel (LocalDef (alias_of_pat pat,cur,ty)) eqn.rhs.rhs_env in
 	{ eqn with
             rhs = { eqn.rhs with rhs_env = rhs_env };
 	    patterns = pats }
@@ -455,9 +459,9 @@ let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns }
 exception NotAdjustable
 
 let rec adjust_local_defs loc = function
-  | (pat :: pats, (_,None,_) :: decls) ->
+  | (pat :: pats, LocalAssum _ :: decls) ->
       pat :: adjust_local_defs loc (pats,decls)
-  | (pats, (_,Some _,_) :: decls) ->
+  | (pats, LocalDef _ :: decls) ->
       PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls)
   | [], [] -> []
   | _ -> raise NotAdjustable
@@ -529,9 +533,10 @@ let dependencies_in_pure_rhs nargs eqns =
   let deps_columns = matrix_transpose deps_rows in
   List.map (List.exists (fun x -> x)) deps_columns
 
-let dependent_decl a = function
-  | (na,None,t) -> dependent a t
-  | (na,Some c,t) -> dependent a t || dependent a c
+let dependent_decl a =
+  function
+  | LocalAssum (na,t) -> dependent a t
+  | LocalDef (na,c,t) -> dependent a t || dependent a c
 
 let rec dep_in_tomatch n = function
   | (Pushed _ | Alias _ | NonDepAlias) :: l -> dep_in_tomatch n l
@@ -602,7 +607,7 @@ let relocate_index_tomatch n1 n2 =
       NonDepAlias :: genrec depth rest
   | Abstract (i,d) :: rest ->
       let i = relocate_rel n1 n2 depth i in
-      Abstract (i,map_rel_declaration (relocate_index n1 n2 depth) d)
+      Abstract (i, map_constr (relocate_index n1 n2 depth) d)
       :: genrec (depth+1) rest in
   genrec 0
 
@@ -635,7 +640,7 @@ let replace_tomatch n c =
   | NonDepAlias  :: rest ->
       NonDepAlias :: replrec depth rest
   | Abstract (i,d) :: rest ->
-      Abstract (i,map_rel_declaration (replace_term n c depth) d)
+      Abstract (i, map_constr (replace_term n c depth) d)
       :: replrec (depth+1) rest in
   replrec 0
 
@@ -660,7 +665,7 @@ let rec liftn_tomatch_stack n depth = function
       NonDepAlias :: liftn_tomatch_stack n depth rest
   | Abstract (i,d)::rest ->
       let i = if i<depth then i else i+n in
-      Abstract (i,map_rel_declaration (liftn n depth) d)
+      Abstract (i, map_constr (liftn n depth) d)
       ::(liftn_tomatch_stack n (depth+1) rest)
 
 let lift_tomatch_stack n = liftn_tomatch_stack n 1
@@ -696,7 +701,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 (Context.Rel.length sign) Anonymous in
   (* If any, we prefer names used in pats, from top to bottom *)
   let names2,aliasname =
     List.fold_right
@@ -714,7 +719,7 @@ let get_names env sign eqns =
       (fun (l,avoid) d na ->
 	 let na =
 	   merge_name
-	     (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid))
+	     (fun (LocalAssum (na,t) | LocalDef (na,_,t)) -> Name (next_name_away (named_hd env t na) avoid))
 	     d na
 	 in
          (na::l,(out_name na)::avoid))
@@ -728,18 +733,16 @@ let get_names env sign eqns =
 (* We now replace the names y1 .. yn y by the actual names       *)
 (* xi1 .. xin xi to be found in the i-th clause of the matrix    *)
 
-let set_declaration_name x (_,c,t) = (x,c,t)
-
-let recover_initial_subpattern_names = List.map2 set_declaration_name
+let recover_initial_subpattern_names = List.map2 set_name
 
 let recover_and_adjust_alias_names names sign =
   let rec aux = function
   | [],[] ->
       []
-  | x::names, (_,None,t)::sign ->
-      (x,(alias_of_pat x,None,t)) :: aux (names,sign)
-  | names, (na,(Some _ as c),t)::sign ->
-      (PatVar (Loc.ghost,na),(na,c,t)) :: aux (names,sign)
+  | x::names, LocalAssum (_,t)::sign ->
+      (x, LocalAssum (alias_of_pat x,t)) :: aux (names,sign)
+  | names, (LocalDef (na,_,_) as decl)::sign ->
+      (PatVar (Loc.ghost,na), decl) :: aux (names,sign)
   | _ -> assert false
   in
   List.split (aux (names,sign))
@@ -754,11 +757,12 @@ let push_rels_eqn_with_names sign eqn =
   let sign = recover_initial_subpattern_names subpatnames sign in
   push_rels_eqn sign eqn
 
-let push_generalized_decl_eqn env n (na,c,t) eqn =
-  let na = match na with
-  | Anonymous -> Anonymous
-  | Name id -> pi1 (Environ.lookup_rel n eqn.rhs.rhs_env) in
-  push_rels_eqn [(na,c,t)] eqn
+let push_generalized_decl_eqn env n decl eqn =
+  match get_name decl with
+  | Anonymous ->
+      push_rels_eqn [decl] eqn
+  | Name _ ->
+      push_rels_eqn [set_name (get_name (Environ.lookup_rel n eqn.rhs.rhs_env)) decl] eqn
 
 let drop_alias_eqn eqn =
   { eqn with alias_stack = List.tl eqn.alias_stack }
@@ -766,7 +770,7 @@ let drop_alias_eqn eqn =
 let push_alias_eqn alias eqn =
   let aliasname = List.hd eqn.alias_stack in
   let eqn = drop_alias_eqn eqn in
-  let alias = set_declaration_name aliasname alias in
+  let alias = set_name aliasname alias in
   push_rels_eqn [alias] eqn
 
 (**********************************************************************)
@@ -837,10 +841,10 @@ let regeneralize_index_predicate n = map_predicate (relocate_index n 1) 0
 let substnl_predicate sigma = map_predicate (substnl sigma)
 
 (* This is parallel bindings *)
-let subst_predicate (args,copt) ccl tms =
+let subst_predicate (subst,copt) ccl tms =
   let sigma = match copt with
-    | None -> List.rev args
-    | Some c -> c::(List.rev args) in
+    | None -> subst
+    | Some c -> c::subst in
   substnl_predicate sigma 0 ccl tms
 
 let specialize_predicate_var (cur,typ,dep) tms ccl =
@@ -921,7 +925,7 @@ let abstract_predicate env sigma indf cur realargs (names,na) tms ccl =
   let tms = List.fold_right2 (fun par arg tomatch ->
     match kind_of_term par with
     | Rel i -> relocate_index_tomatch (i+n) (destRel arg) tomatch
-    | _ -> tomatch) (realargs@[cur]) (extended_rel_list 0 sign)
+    | _ -> tomatch) (realargs@[cur]) (Context.Rel.to_extended_list 0 sign)
        (lift_tomatch_stack n tms) in
   (* Pred is already dependent in the current term to match (if      *)
   (* (na<>Anonymous) and its realargs; we just need to adjust it to  *)
@@ -932,7 +936,7 @@ let abstract_predicate env sigma indf cur realargs (names,na) tms 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
+  let sign = List.map2 set_name (na::names) sign in
   it_mkLambda_or_LetIn_name env pred sign
 
 (* [expand_arg] is used by [specialize_predicate]
@@ -1018,7 +1022,7 @@ let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl =
   (* We prepare the substitution of X and x:I(X) *)
   let realargsi =
     if not (Int.equal nrealargs 0) then
-      adjust_subst_to_rel_context arsign (Array.to_list cs.cs_concl_realargs)
+      subst_of_rel_context_instance arsign (Array.to_list cs.cs_concl_realargs)
     else
       [] in
   let copti = match depna with
@@ -1118,14 +1122,14 @@ 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
-      let is_d = match d with (_, None, _) -> false | _ -> true in
+      let d = map_constr (nf_evar evd) d in
+      let is_d = match d with LocalAssum _ -> false | LocalDef _ -> 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 = match d with
-        | (_, None, _) -> mkRel n :: inst
+        | LocalAssum _ -> mkRel n :: inst
         | _ -> inst
         in
         brs, Abstract (i,d) :: tomatch, pred, inst
@@ -1187,12 +1191,13 @@ let group_equations pb ind current cstrs mat =
 let rec generalize_problem names pb = function
   | [] -> pb, []
   | 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
-      begin match (na, b) with
-      | Anonymous, Some _ -> pb', deps
+      let d = map_constr (lift i) (Environ.lookup_rel i pb.env) in
+      begin match d with
+      | LocalDef (Anonymous,_,_) -> pb', deps
       | _ ->
-        let d = on_pi3 (whd_betaiota !(pb.evdref)) d in (* for better rendering *)
+	 (* for better rendering *)
+	let d = map_type (whd_betaiota !(pb.evdref)) d in
         let tomatch = lift_tomatch_stack 1 pb'.tomatch in
         let tomatch = relocate_index_tomatch (i+1) 1 tomatch in
         { pb' with
@@ -1220,7 +1225,8 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn
   (* that had matched constructor C *)
   let cs_args = const_info.cs_args in
   let names,aliasname = get_names pb.env cs_args eqns in
-  let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in
+  let typs = List.map2 set_name names cs_args
+  in
 
   (* We build the matrix obtained by expanding the matching on *)
   (* "C x1..xn as x" followed by a residual matching on eqn into *)
@@ -1230,7 +1236,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn
   (* 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_constr (lift i) d)) 1 typs in
 
   let extenv = push_rel_context typs pb.env in
 
@@ -1268,7 +1274,8 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn
 
   let typs' =
     List.map2
-      (fun (tm,(tmtyp,_),(na,_,_)) deps ->
+      (fun (tm, (tmtyp,_), decl) deps ->
+        let na = get_name decl in
 	let na = match curname, na with
 	| Name _, Anonymous -> curname
 	| Name _, Name _ -> na
@@ -1324,14 +1331,6 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn
 
 *)
 
-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 =
@@ -1378,7 +1377,9 @@ and match_current pb (initial,tomatch) =
 	      pred current indt (names,dep) tomatch in
 	  let ci = make_case_info pb.env (fst mind) pb.casestyle in
 	  let pred = nf_betaiota !(pb.evdref) pred in
-	  let case = mk_case pb (ci,pred,current,brvals) in
+	  let case =
+	    make_case_or_project pb.env indf 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 }
@@ -1392,7 +1393,7 @@ and shift_problem ((current,t),_,na) pb =
   let pred = specialize_predicate_var (current,t,na) pb.tomatch pb.pred in
   let pb =
     { pb with
-       env = push_rel (na,Some current,ty) pb.env;
+       env = push_rel (LocalDef (na,current,ty)) pb.env;
        tomatch = tomatch;
        pred = lift_predicate 1 pred tomatch;
        history = pop_history pb.history;
@@ -1440,7 +1441,7 @@ and compile_generalization pb i d rest =
    ([false]). *)
 and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest =
   let f c t =
-    let alias = (na,Some c,t) in
+    let alias = LocalDef (na,c,t) in
     let pb =
       { pb with
          env = push_rel alias pb.env;
@@ -1560,8 +1561,8 @@ let matx_of_eqns env eqns =
 *)
 
 let adjust_to_extended_env_and_remove_deps env extenv subst t =
-  let n = rel_context_length (rel_context env) in
-  let n' = rel_context_length (rel_context extenv) in
+  let n = Context.Rel.length (rel_context env) in
+  let n' = Context.Rel.length (rel_context extenv) in
   (* We first remove the bindings that are dependently typed (they are
      difficult to manage and it is not sure these are so useful in practice);
      Notes:
@@ -1576,9 +1577,9 @@ let adjust_to_extended_env_and_remove_deps env extenv subst t =
     (* \--------------extenv------------/ *)
     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
+      match lookup_rel p extenv with
+      | LocalDef (_,c,_) -> assert (isRel c); traverse_local_defs (p + destRel c)
+      | LocalAssum _ -> p in
     let p = traverse_local_defs p in
     let u = lift (n' - n) u in
     try Some (p, u, expand_vars_in_term extenv u)
@@ -1623,7 +1624,7 @@ 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 -> t
+    | Rel n when is_local_def (lookup_rel n env) -> t
     | Evar ev ->
         let ty = get_type_of env !evdref t in
 	let ty = Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref ty in
@@ -1659,7 +1660,8 @@ let abstract_tycon loc env evdref subst tycon extenv t =
 	List.map (fun a -> not (isRel a) || dependent a u
                            || Int.Set.mem (destRel a) depvl) inst in
       let named_filter =
-	List.map (fun (id,_,_) -> dependent (mkVar id) u)
+        let open Context.Named.Declaration in
+	List.map (fun d -> dependent (mkVar (get_id d)) u)
 	  (named_context extenv) in
       let filter = Filter.make (rel_filter @ named_filter) in
       let candidates = u :: List.map mkRel vl in
@@ -1673,8 +1675,8 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t =
     | None ->
 	(* This is the situation we are building a return predicate and
            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 n = Context.Rel.length (rel_context env) in
+	let n' = Context.Rel.length (rel_context tycon_env) in
 	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)
@@ -1702,7 +1704,7 @@ let build_inversion_problem loc env sigma tms t =
     let id = next_name_away (named_hd env t Anonymous) 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
+    match kind_of_term (whd_all env sigma t) with
     | Construct (cstr,u) -> PatCstr (Loc.ghost,cstr,[],Anonymous), acc
     | App (f,v) when isConstruct f ->
 	let cstr,u = destConstruct f in
@@ -1727,7 +1729,7 @@ let build_inversion_problem loc env sigma tms t =
 	List.rev_append patl patl',acc_sign,acc
     | (t, NotInd (bo,typ)) :: tms ->
       let pat,acc = make_patvar t acc in
-      let d = (alias_of_pat pat,None,typ) in
+      let d = LocalAssum (alias_of_pat pat,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
@@ -1744,7 +1746,7 @@ 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_constr (lift i) d)) 1 sign in
 
   let pb_env = push_rel_context sign env in
   let decls =
@@ -1754,17 +1756,17 @@ let build_inversion_problem loc env sigma tms t =
   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 List.is_empty deps then Anonymous else force_name na in
+    List.map2 (fun deps (tm, (tmtyp,_), decl) ->
+      let na = if List.is_empty deps then Anonymous else force_name (get_name decl) 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
+  (* [main_eqn] is the main clause of the auxiliary pattern-matching that
      serves as skeleton for the return type: [patl] is the
      substructure of constructors extracted from the list of
      constraints on the inductive types of the multiple terms matched
      in the original pattern-matching problem Xi *)
-  let eqn1 =
+  let main_eqn =
     { patterns = patl;
       alias_stack = [];
       eqn_loc = Loc.ghost;
@@ -1775,36 +1777,37 @@ let build_inversion_problem loc env sigma tms t =
               rhs_vars = List.map fst subst;
               avoid_ids = avoid;
 	      it = Some (lift n t) } } in
-  (* [eqn2] is the default clause of the auxiliary pattern-matching: it will
-     catch the clauses of the original pattern-matching problem Xi whose
-     type constraints are incompatible with the constraints on the
+  (* [catch_all] is a catch-all default clause of the auxiliary
+     pattern-matching, if needed: it will catch the clauses
+     of the original pattern-matching problem Xi whose 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 (Loc.ghost,Anonymous)) patl;
-      alias_stack = [];
-      eqn_loc = Loc.ghost;
-      used = ref false;
-      rhs = { rhs_env = pb_env;
-              rhs_vars = [];
-	      avoid_ids = avoid0;
-	      it = None } } in
+  let catch_all_eqn =
+    if List.for_all (irrefutable env) patl then
+      (* No need for a catch all clause *)
+      []
+    else
+      [ { patterns = List.map (fun _ -> PatVar (Loc.ghost,Anonymous)) patl;
+          alias_stack = [];
+          eqn_loc = Loc.ghost;
+          used = ref false;
+          rhs = { rhs_env = pb_env;
+                  rhs_vars = [];
+	          avoid_ids = avoid0;
+	          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      = (*ty *) mkSort s;
       tomatch   = sub_tms;
       history   = start_history n;
-      mat       = [eqn1;eqn2];
+      mat       = main_eqn :: catch_all_eqn;
       caseloc   = loc;
       casestyle = RegularStyle;
       typing_function = build_tycon loc env pb_env s subst} in
@@ -1816,7 +1819,8 @@ let build_inversion_problem loc env sigma tms t =
 let build_initial_predicate arsign pred =
   let rec buildrec n pred tmnames = function
     | [] -> List.rev tmnames,pred
-    | ((na,c,t)::realdecls)::lnames ->
+    | (decl::realdecls)::lnames ->
+        let na = get_name decl in
         let n' = n + List.length realdecls in
         buildrec (n'+1) pred (force_name na::tmnames) lnames
     | _ -> assert false
@@ -1828,7 +1832,9 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign =
     match tm with
       | NotInd (bo,typ) ->
 	  (match t with
-	    | None -> [na,Option.map (lift n) bo,lift n typ]
+	    | None -> (match bo with
+		       | None -> [LocalAssum (na, lift n typ)]
+		       | Some b -> [LocalDef (na, lift n b, lift n typ)])
 	    | Some (loc,_,_) ->
  	    user_err_loc (loc,"",
 	    str"Unexpected type annotation for a term of non inductive type."))
@@ -1846,8 +1852,8 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign =
 		      anomaly (Pp.str "Ill-formed 'in' clause in cases");
 		  List.rev realnal
 	      | 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
+	  LocalAssum (na, build_dependent_inductive env0 indf')
+	  ::(List.map2 set_name realnal arsign) in
   let rec buildrec n = function
     | [],[] -> []
     | (_,tm)::ltm, (_,x)::tmsign ->
@@ -1867,7 +1873,7 @@ let inh_conv_coerce_to_tycon loc env evdref j tycon =
 (* We put the tycon inside the arity signature, possibly discovering dependencies. *)
 
 let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c =
-  let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in
+  let nar = List.fold_left (fun n sign -> Context.Rel.nhyps sign + n) 0 arsign in
   let subst, len =
     List.fold_right2 (fun (tm, tmtype) sign (subst, len) ->
       let signlen = List.length sign in
@@ -1928,14 +1934,22 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c =
  *)
 
 let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred =
+  let refresh_tycon sigma t =
+    (** If we put the typing constraint in the term, it has to be
+       refreshed to preserve the invariant that no algebraic universe
+       can appear in the term.  *)
+    refresh_universes ~status:Evd.univ_flexible ~onlyalg:true (Some true)
+		      env sigma t
+  in
   let preds =
     match pred, tycon with
-    (* No type annotation *)
+    (* No return clause *)
     | 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 *)
-        let p1 =
+       (* First strategy: we abstract the tycon wrt to the dependencies *)
+         let sigma, t = refresh_tycon sigma t in
+         let p1 =
           prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign t in
 	(* Second strategy: we build an "inversion" predicate *)
 	let sigma2,pred2 = build_inversion_problem loc env sigma tomatchs t in
@@ -1946,10 +1960,12 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred =
 	(* No dependent type constraint, or no constraints at all: *)
 	(* we use two strategies *)
         let sigma,t = match tycon with
-	| Some t -> sigma,t
+	| Some t -> refresh_tycon sigma t
 	| None -> 
-	  let sigma, (t, _) = 
+          let sigma = Sigma.Unsafe.of_evar_map sigma in
+          let Sigma ((t, _), sigma, _) =
 	    new_type_evar env sigma univ_flexible_alg ~src:(loc, Evar_kinds.CasesType false) in
+          let sigma = Sigma.to_evar_map sigma in
 	    sigma, t
 	in
         (* First strategy: we build an "inversion" predicate *)
@@ -1965,12 +1981,6 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred =
       let evdref = ref sigma in
       let predcclj = typing_fun (mk_tycon (mkSort newt)) envar evdref rtntyp 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
@@ -2016,7 +2026,9 @@ let mk_JMeq evdref 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 hole =
+  GHole (Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define false),
+         Misctypes.IntroAnonymous, None)
 
 let constr_of_pat env evdref arsign pat avoid =
   let rec typ env (ty, realargs) pat avoid =
@@ -2028,7 +2040,7 @@ let constr_of_pat env evdref arsign pat avoid =
 	      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, 
+	  (PatVar (l, name), [LocalAssum (name, 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
@@ -2045,7 +2057,8 @@ let constr_of_pat env evdref arsign pat avoid =
 	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)  ->
+	    (fun decl ua (patargs, args, sign, env, n, m, avoid)  ->
+               let t = get_type decl in
 	       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
@@ -2067,7 +2080,7 @@ let constr_of_pat env evdref arsign pat avoid =
 	      Anonymous ->
 		pat', sign, app, apptype, realargs, n, avoid
 	    | Name id ->
-		let sign = (alias, None, lift m ty) :: sign in
+		let sign = LocalAssum (alias, lift m ty) :: sign in
 		let avoid = id :: avoid in
 		let sign, i, avoid =
 		  try
@@ -2079,14 +2092,14 @@ let constr_of_pat env evdref arsign pat avoid =
 		      (lift 1 app) (* aliased term *)
 		    in
 		    let neq = eq_id avoid id in
-		      (Name neq, Some (mkRel 0), eq_t) :: sign, 2, neq :: avoid
+		      LocalDef (Name neq, 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
+  let pat', sign, patc, patty, args, z, avoid = typ env (get_type (List.hd arsign), List.tl arsign) pat avoid in
+    pat', (sign, patc, (get_type (List.hd arsign), args), pat'), avoid
 
 
 (* shadows functional version *)
@@ -2101,23 +2114,23 @@ 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 rels_of_patsign =
+  List.map (fun decl ->
+	    match decl with
+	    | LocalDef (na,t',t) when is_topvar t' -> LocalAssum (na,t)
+	    | _ -> decl)
 
 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' ->
+    List.fold_right (fun decl (prev, vars) ->
+      match decl with
+	| LocalDef (na,t',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
+	    match get_name decl with
 		Anonymous -> invalid_arg "vars_of_ctx"
 	      | Name n -> n, GVar (Loc.ghost, n) :: vars)
       ctx (Id.of_string "vars_of_ctx_error", [])
@@ -2226,7 +2239,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity =
 	     match ineqs with
 	     | None -> [], arity
 	     | Some ineqs ->
-		 [Anonymous, None, ineqs], lift 1 arity
+		 [LocalAssum (Anonymous, ineqs)], lift 1 arity
 	   in
 	   let eqs_rels, arity = decompose_prod_n_assum neqs arity in
 	     eqs_rels @ neqs_rels @ rhs_rels', arity
@@ -2237,7 +2250,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity =
 	 and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in
 	 let _btype = evd_comb1 (Typing.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_decl = LocalDef (Name branch_name, lift !i bbody, lift !i btype) in
 	 let branch =
 	   let bref = GVar (Loc.ghost, branch_name) in
 	     match vars_of_ctx rhs_rels with
@@ -2286,7 +2299,7 @@ let abstract_tomatch env tomatchs tycon =
 		 (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,
+	       LocalDef (Name name, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx,
 	       name :: names, tycon)
       ([], [], [], tycon) tomatchs
   in List.rev prev, ctx, tycon
@@ -2294,7 +2307,7 @@ let abstract_tomatch env tomatchs 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 allnames = List.rev_map (List.map get_name) 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
@@ -2310,11 +2323,15 @@ let build_dependent_signature env evdref avoid tomatchs arsign =
 	     (* 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 app_decl = List.hd arsign in (* The matched argument *)
+	     let appn = get_name app_decl in
+	     let appt = get_type app_decl in
 	     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) ->
+		 (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg decl ->
+		    let name = get_name decl in
+		    let t = get_type decl in
 		    let argt = Retyping.get_type_of env !evdref arg in
 		    let eq, refl_arg =
 		      if Reductionops.is_conv env !evdref argt t then
@@ -2332,16 +2349,16 @@ let build_dependent_signature env evdref avoid tomatchs arsign =
 		    let previd, id =
 		      let name =
 			match kind_of_term arg with
-			Rel n -> pi1 (lookup_rel n env)
+			Rel n -> get_name (lookup_rel n env)
 			| _ -> name
 		      in
 			make_prime avoid name
 		    in
 		      (env, succ nargeqs,
-		       (Name (eq_id avoid previd), None, eq) :: argeqs,
+		       (LocalAssum (Name (eq_id avoid previd), eq)) :: argeqs,
 		       refl_arg :: refl_args,
 		       pred slift,
-		       (Name id, b, t) :: argsign'))
+		       set_name (Name id) decl :: argsign'))
 		 (env, neqs, [], [], slift, []) args argsign
 	     in
 	     let eq = mk_JMeq evdref
@@ -2352,22 +2369,23 @@ let build_dependent_signature env evdref avoid tomatchs arsign =
 	     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,
+	       ((LocalAssum (Name (eq_id avoid previd), eq) :: argeqs) :: eqs,
 		succ nargeqs,
 		refl_eq :: refl_args,
 		pred slift,
-		(((Name id, appb, appt) :: argsign') :: arsigns))
+		((set_name (Name id) app_decl :: 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 decl = match arsign with [x] -> x | _ -> assert(false) in
+	     let name = get_name decl in
 	     let previd, id = make_prime avoid name in
-	     let arsign' = (Name id, b, typ) in
+	     let arsign' = set_name (Name id) decl 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,
+	       ([LocalAssum (Name (eq_id avoid previd), eq)] :: eqs, succ neqs,
 		(mk_eq_refl evdref tomatch_ty tm) :: refl_args,
 		pred slift, (arsign' :: []) :: arsigns))
       ([], 0, [], nar, []) tomatchs arsign
@@ -2412,7 +2430,7 @@ let compile_program_cases loc style (typing_function, evdref) tycon env
     match tycon' with
     | None -> let ev = mkExistential env evdref in ev, ev
     | Some t ->
-	let pred = 
+	let pred =
 	  match prepare_predicate_from_arsign_tycon env !evdref loc tomatchs sign t with
 	  | Some (evd, pred) -> evdref := evd; pred
 	  | None ->
@@ -2441,7 +2459,9 @@ let compile_program_cases loc style (typing_function, evdref) tycon env
   (* 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 out_tmt na = function NotInd (None,t) -> LocalAssum (na,t)
+			  | NotInd (Some b, t) -> LocalDef (na,b,t)
+			  | IsInd (typ,_,_) -> LocalAssum (na,typ) in
   let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in
     
   let typs =
@@ -2489,11 +2509,11 @@ let compile_program_cases loc style (typing_function, evdref) tycon env
 (* 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) 
+  if predopt == None && Flags.is_program_mode () && Program.is_program_cases () 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 eqns in
 
@@ -2514,7 +2534,9 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e
     (* 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 out_tmt na = function NotInd (None,t) -> LocalAssum (na,t)
+			    | NotInd (Some b,t) -> LocalDef (na,b,t)
+			    | IsInd (typ,_,_) -> LocalAssum (na,typ) in
     let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in
 
     let typs =
@@ -2553,6 +2575,9 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e
 	typing_function = typing_fun } in
 
     let j = compile pb in
+
+    (* We coerce to the tycon (if an elim predicate was provided) *)
+    let j = inh_conv_coerce_to_tycon loc env myevdref j tycon in
     evdref := !myevdref;
     j in
 
@@ -2563,6 +2588,4 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e
   (* We check for unused patterns *)
   List.iter (check_unused_pattern env) matx;
 
-  (* We coerce to the tycon (if an elim predicate was provided) *)
-  inh_conv_coerce_to_tycon loc env evdref j tycon
-
+  j
diff --git a/pretyping/cases.mli b/pretyping/cases.mli
index ab00aa16..ee4148de 100644
--- a/pretyping/cases.mli
+++ b/pretyping/cases.mli
@@ -8,7 +8,6 @@
 
 open Names
 open Term
-open Context
 open Evd
 open Environ
 open Inductiveops
@@ -33,6 +32,8 @@ val error_wrong_numarg_constructor_loc : Loc.t -> env -> constructor -> int -> '
 
 val error_wrong_numarg_inductive_loc : Loc.t -> env -> inductive -> int -> 'a
 
+val irrefutable : env -> cases_pattern -> bool
+
 (** {6 Compilation primitive. } *)
 
 val compile_cases :
@@ -45,11 +46,11 @@ val compile_cases :
 val constr_of_pat : 
            Environ.env ->
            Evd.evar_map ref ->
-           rel_declaration list ->
+           Context.Rel.Declaration.t list ->
            Glob_term.cases_pattern ->
            Names.Id.t list ->
            Glob_term.cases_pattern *
-           (rel_declaration list * Term.constr *
+           (Context.Rel.Declaration.t list * Term.constr *
             (Term.types * Term.constr list) * Glob_term.cases_pattern) *
            Names.Id.t list
 
@@ -83,7 +84,7 @@ 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
+  | Abstract of int * Context.Rel.Declaration.t
 
 type tomatch_stack = tomatch_status list
 
@@ -113,11 +114,11 @@ val compile : 'a pattern_matching_problem -> Environ.unsafe_judgment
 
 val prepare_predicate :            Loc.t ->
            (Evarutil.type_constraint ->
-            Environ.env -> Evd.evar_map ref -> 'a -> Environ.unsafe_judgment) ->
+            Environ.env -> Evd.evar_map ref -> glob_constr -> Environ.unsafe_judgment) ->
            Environ.env ->
            Evd.evar_map ->
            (Term.types * tomatch_type) list ->
-           Context.rel_context list ->
+           Context.Rel.t list ->
            Constr.constr option ->
-           'a option -> (Evd.evar_map * Names.name list * Term.constr) list
-
+           glob_constr option ->
+           (Evd.evar_map * Names.name list * Term.constr) list
diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml
index 43062a0e..84bf849e 100644
--- a/pretyping/cbv.ml
+++ b/pretyping/cbv.ml
@@ -10,7 +10,7 @@ open Util
 open Names
 open Term
 open Vars
-open Closure
+open CClosure
 open Esubst
 
 (**** Call by value reduction ****)
@@ -156,7 +156,7 @@ let strip_appl head stack =
 
 (* Tests if fixpoint reduction is possible. *)
 let fixp_reducible flgs ((reci,i),_) stk =
-  if red_set flgs fIOTA then
+  if red_set flgs fFIX then
     match stk with
       | APP(appl,_) ->
           Array.length appl > reci.(i) &&
@@ -168,7 +168,7 @@ let fixp_reducible flgs ((reci,i),_) stk =
     false
 
 let cofixp_reducible flgs _ stk =
-  if red_set flgs fIOTA then
+  if red_set flgs fCOFIX then
     match stk with
       | (CASE _ | APP(_,CASE _)) -> true
       | _ -> false
@@ -296,21 +296,21 @@ and cbv_stack_value info env = function
 
     (* constructor in a Case -> IOTA *)
     | (CONSTR(((sp,n),u),[||]), APP(args,CASE(_,br,ci,env,stk)))
-            when red_set (info_flags info) fIOTA ->
+            when red_set (info_flags info) fMATCH ->
 	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),u),[||]), CASE(_,br,_,env,stk))
-            when red_set (info_flags info) fIOTA ->
+            when red_set (info_flags info) fMATCH ->
                     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 ->
+        when red_set (info_flags info) fMATCH && Projection.unfolded p ->
       let arg = args.(pi.Declarations.proj_npars + pi.Declarations.proj_arg) in
-	cbv_stack_value info env (arg, stk)
+	cbv_stack_value info env (strip_appl arg stk)
 
     (* may be reduced later by application *)
     | (FIXP(fix,env,[||]), APP(appl,TOP)) -> FIXP(fix,env,appl)
diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli
index de37d1fc..87a03abb 100644
--- a/pretyping/cbv.mli
+++ b/pretyping/cbv.mli
@@ -9,7 +9,7 @@
 open Names
 open Term
 open Environ
-open Closure
+open CClosure
 open Esubst
 
 (***********************************************************************
diff --git a/pretyping/classops.ml b/pretyping/classops.ml
index ece92b66..4f265e76 100644
--- a/pretyping/classops.ml
+++ b/pretyping/classops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Pp
 open Flags
@@ -297,7 +297,7 @@ let lookup_path_to_sort_from env sigma s =
 
 let get_coercion_constructor env coe =
   let c, _ =
-    Reductionops.whd_betadeltaiota_stack env Evd.empty coe.coe_value
+    Reductionops.whd_all_stack env Evd.empty coe.coe_value
   in
   match kind_of_term c with
   | Construct (cstr,u) ->
@@ -387,7 +387,7 @@ let add_coercion_in_graph (ic,source,target) =
   end;
   let is_ambig = match !ambig_paths with [] -> false | _ -> true in
   if is_ambig && is_verbose () then
-    msg_warning (message_ambig !ambig_paths)
+    Feedback.msg_info (message_ambig !ambig_paths)
 
 type coercion = {
   coercion_type   : coe_typ;
diff --git a/pretyping/classops.mli b/pretyping/classops.mli
index cf88be62..d509739c 100644
--- a/pretyping/classops.mli
+++ b/pretyping/classops.mli
@@ -26,6 +26,9 @@ val cl_typ_eq : cl_typ -> cl_typ -> bool
 
 val subst_cl_typ : substitution -> cl_typ -> cl_typ
 
+(** Comparison of [cl_typ] *)
+val cl_typ_ord : cl_typ -> cl_typ -> int
+
 (** This is the type of infos for declared classes *)
 type cl_info_typ = {
   cl_param : int }
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index 489a311b..913e80f3 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.ml
@@ -14,7 +14,7 @@
    Corbineau, Feb 2008 *)
 (* Turned into an abstract compilation unit by Matthieu Sozeau, March 2006 *)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Term
@@ -63,7 +63,7 @@ let apply_coercion_args env evd check isproj argl funj =
 	{ 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
+      match kind_of_term (whd_all 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;
@@ -90,8 +90,9 @@ let inh_pattern_coerce_to loc env pat ind1 ind2 =
 
 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 make_existential loc ?(opaque = not (get_proofs_transparency ()))  env evdref c =
+  let src = (loc, Evar_kinds.QuestionMark (Evar_kinds.Define opaque)) in
+  Evarutil.e_new_evar env evdref ~src c
 
 let app_opt env evdref f t =
   whd_betaiota !evdref (app_opt f t)
@@ -115,7 +116,7 @@ let disc_subset x =
 
 exception NoSubtacCoercion
   
-let hnf env evd c = whd_betadeltaiota env evd c
+let hnf env evd c = whd_all env evd c
 let hnf_nodelta env evd c = whd_betaiota evd c
 
 let lift_args n sign =
@@ -129,7 +130,7 @@ let mu env evdref t =
   let rec aux v =
     let v' = hnf env !evdref v in
       match disc_subset v' with
-      Some (u, p) ->
+      | Some (u, p) ->
 	let f, ct = aux u in
 	let p = hnf_nodelta env !evdref p in
 	  (Some (fun x ->
@@ -142,6 +143,7 @@ let mu env evdref t =
 and coerce loc env evdref (x : Term.constr) (y : Term.constr)
     : (Term.constr -> Term.constr) option
     =
+  let open Context.Rel.Declaration in
   let rec coerce_unify env x y =
     let x = hnf env !evdref x and y = hnf env !evdref y in
       try
@@ -151,8 +153,9 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
   and coerce' env x y : (Term.constr -> Term.constr) option =
     let subco () = subset_coerce env evdref x y in
     let dest_prod c =
+      let open Context.Rel.Declaration in
       match Reductionops.splay_prod_n env ( !evdref) 1 c with
-      | [(na,b,t)], c -> (na,t), c
+      | [LocalAssum (na,t) | LocalDef (na,_,t)], c -> (na,t), c
       | _ -> raise NoSubtacCoercion
     in
     let coerce_application typ typ' c c' l l' =
@@ -187,9 +190,9 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
 		    (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)
+	    Typing.e_solve_evars env evdref term)
       in
-	if isEvar c || isEvar c' then
+	if isEvar c || isEvar c' || not (Program.is_program_generalized_coercion ()) then
 	  (* Second-order unification needed. *)
 	  raise NoSubtacCoercion;
 	aux [] typ typ' 0 (fun x -> x)
@@ -205,7 +208,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
 	  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 env' = push_rel (LocalAssum (name', 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
@@ -241,9 +244,8 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
 		     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
+			   let (evs, t) = Evardefine.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
@@ -255,7 +257,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
 		       | _ -> 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 env' = push_rel (LocalAssum (Name Namegen.default_dependent_ident, a)) env in
 		     let c2 = coerce_unify env' b b' in
 		       match c1, c2 with
 		       | None, None -> None
@@ -278,7 +280,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
 		     let c1 = coerce_unify env a a' in
 		     let c2 = coerce_unify env b b' in
 		       match c1, c2 with
-		       None, None -> None
+		       | None, None -> None
 		       | _, _ ->
 			   Some
 			     (fun x ->
@@ -297,9 +299,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
 		      with NoSubtacCoercion ->
 			let typ = Typing.unsafe_type_of env evm c in
 			let typ' = Typing.unsafe_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' ->
@@ -307,9 +307,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
 		 let evm =  !evdref in
 		 let lam_type = Typing.unsafe_type_of env evm c in
 		 let lam_type' = Typing.unsafe_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 ()
@@ -335,10 +333,17 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
 	    raise NoSubtacCoercion
   in coerce_unify env x y
 
+let app_coercion env evdref coercion v =
+  match coercion with
+  | None -> v
+  | Some f ->
+     let v' = Typing.e_solve_evars env evdref (f v) in
+     whd_betaiota !evdref v'
+
 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
+  let t = Option.map (app_coercion env evdref coercion) v in
     !evdref, t
 
 let saturate_evd env evd =
@@ -365,15 +370,15 @@ let apply_coercion env sigma p hj typ_cl =
       (hj,typ_cl,sigma) p
     in evd, j
   with NoCoercion as e -> raise e
-  | e when Errors.noncritical e -> anomaly (Pp.str "apply_coercion")
+  | e when CErrors.noncritical e -> anomaly (Pp.str "apply_coercion")
 
 (* Try to coerce to a funclass; raise NoCoercion if not possible *)
 let inh_app_fun_core env evd j =
-  let t = whd_betadeltaiota env evd j.uj_type in
+  let t = whd_all 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
+	let (evd',t) = Evardefine.define_evar_as_product evd ev in
 	  (evd',{ uj_val = j.uj_val; uj_type = t })
     | _ ->
       	try let t,p =
@@ -410,11 +415,11 @@ let inh_tosort_force loc env evd j =
     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
+  let typ = whd_all 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
+	let (evd',s) = Evardefine.define_evar_as_sort env evd ev in
 	  (evd',{ utj_val = j.uj_val; utj_type = s })
     | _ ->
 	inh_tosort_force loc env evd j
@@ -424,7 +429,7 @@ let inh_coerce_to_base loc env evd j =
     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_val = app_coercion env evdref ct j.uj_val;
 	uj_type = typ' }
     in !evdref, res
   else (evd, j)
@@ -462,8 +467,8 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 =
     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)
+      kind_of_term (whd_all env evd t),
+      kind_of_term (whd_all env evd c1)
       with
       | Prod (name,t1,t2), Prod (_,u1,u2) ->
           (* Conversion did not work, we may succeed with a coercion. *)
@@ -475,7 +480,8 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 =
 	  let name = match name with
 	    | Anonymous -> Name Namegen.default_dependent_ident
 	    | _ -> name in
-	  let env1 = push_rel (name,None,u1) env in
+	  let open Context.Rel.Declaration in
+	  let env1 = push_rel (LocalAssum (name,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
@@ -508,7 +514,7 @@ let inh_conv_coerce_to_gen resolve_tc rigidonly loc env evd cj t =
 	      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) ->
+	  with NoCoercionNoUnifier (_evd,_error) ->
 	    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
diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml
index ee3c43d8..886a9826 100644
--- a/pretyping/constr_matching.ml
+++ b/pretyping/constr_matching.ml
@@ -8,7 +8,7 @@
 
 (*i*)
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Globnames
@@ -17,10 +17,10 @@ open Termops
 open Reductionops
 open Term
 open Vars
-open Context
 open Pattern
 open Patternops
 open Misctypes
+open Context.Rel.Declaration
 (*i*)
 
 (* Given a term with second-order variables in it,
@@ -49,12 +49,12 @@ 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_meta_collision =
+  CWarnings.create ~name:"meta-collision" ~category:"ltac"
+         (fun name ->
+          strbrk "Collision between bound variable " ++ pr_id name ++
+            strbrk " and a metavariable of same name.")
 
-let warn_bound_bound name =
-  msg_warning (str "Collision between bound variables of name " ++ pr_id name)
 
 let constrain n (ids, m as x) (names, terms as subst) =
   try
@@ -62,18 +62,19 @@ let constrain n (ids, m as x) (names, terms as subst) =
     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
+    let () = if Id.Map.mem n names then warn_meta_collision n in
     (names, Id.Map.add n x terms)
 
 let add_binders na1 na2 binding_vars (names, terms as subst) =
   match na1, na2 with
   | Name id1, Name id2 when Id.Set.mem id1 binding_vars ->
     if Id.Map.mem id1 names then
-      let () = warn_bound_bound id1 in
+      let () = Glob_ops.warn_variable_collision id1 in
       (names, terms)
     else
       let names = Id.Map.add id1 id2 names in
-      let () = if Id.Map.mem id1 terms then warn_bound_meta id1 in
+      let () = if Id.Map.mem id1 terms then
+        warn_meta_collision id1 in
       (names, terms)
   | _ -> subst
 
@@ -255,24 +256,24 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels
           sorec ctx env subst c1 c2
 
       | PProd (na1,c1,d1), Prod(na2,c2,d2) ->
-	  sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env)
+	  sorec ((na1,na2,c2)::ctx) (Environ.push_rel (LocalAssum (na2,c2)) env)
             (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2
 
       | PLambda (na1,c1,d1), Lambda(na2,c2,d2) ->
-	  sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env)
+	  sorec ((na1,na2,c2)::ctx) (Environ.push_rel (LocalAssum (na2,c2)) env)
             (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2
 
       | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) ->
-	  sorec ((na1,na2,t2)::ctx) (Environ.push_rel (na2,Some c2,t2) env)
+	  sorec ((na1,na2,t2)::ctx) (Environ.push_rel (LocalDef (na2,c2,t2)) env)
             (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2
 
       | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) ->
 	  let ctx_b2,b2 = decompose_lam_n_decls ci.ci_cstr_ndecls.(0) b2 in
 	  let ctx_b2',b2' = decompose_lam_n_decls ci.ci_cstr_ndecls.(1) b2' in
-	  let n = rel_context_length ctx_b2 in
-          let n' = rel_context_length ctx_b2' in
+	  let n = Context.Rel.length ctx_b2 in
+          let n' = Context.Rel.length ctx_b2' in
 	  if noccur_between 1 n b2 && noccur_between 1 n' b2' then
-            let f l (na,_,t) = (Anonymous,na,t)::l in
+            let f l (LocalAssum (na,t) | LocalDef (na,_,t)) = (Anonymous,na,t)::l in
 	    let ctx_br = List.fold_left f ctx ctx_b2 in
 	    let ctx_br' = List.fold_left f ctx ctx_b2' in
 	    let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in
@@ -368,21 +369,21 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c =
       | [c1; c2] -> mk_ctx (mkLambda (x, c1, c2))
       | _ -> assert false
       in
-      let env' = Environ.push_rel (x,None,c1) env in
+      let env' = Environ.push_rel (LocalAssum (x,c1)) env in
       try_aux [(env, c1); (env', c2)] next_mk_ctx next
   | Prod (x,c1,c2) ->
       let next_mk_ctx = function
       | [c1; c2] -> mk_ctx (mkProd (x, c1, c2))
       | _ -> assert false
       in
-      let env' = Environ.push_rel (x,None,c1) env in
+      let env' = Environ.push_rel (LocalAssum (x,c1)) env in
       try_aux [(env, c1); (env', c2)] next_mk_ctx next
   | LetIn (x,c1,t,c2) ->
       let next_mk_ctx = function
       | [c1; c2] -> mk_ctx (mkLetIn (x, c1, t, c2))
       | _ -> assert false
       in
-      let env' = Environ.push_rel (x,Some c1,t) env in
+      let env' = Environ.push_rel (LocalDef (x,c1,t)) env in
       try_aux [(env, c1); (env', c2)] next_mk_ctx next
   | App (c1,lc) ->
         let topdown = true in
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index c3877c56..85125a50 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -7,12 +7,11 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Term
 open Vars
-open Context
 open Inductiveops
 open Environ
 open Glob_term
@@ -25,6 +24,7 @@ open Nametab
 open Mod_subst
 open Misctypes
 open Decl_kinds
+open Context.Named.Declaration
 
 let dl = Loc.ghost
 
@@ -34,8 +34,15 @@ 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) = 
+let add_name na b t (nenv, env) =
+  let open Context.Rel.Declaration in
+  add_name na nenv, push_rel (match b with
+			      | None -> LocalAssum (na,t)
+			      | Some b -> LocalDef (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)
@@ -199,7 +206,7 @@ let computable p k =
        engendrera un prédicat non dépendant) *)
 
   let sign,ccl = decompose_lam_assum p in
-  Int.equal (rel_context_length sign) (k + 1)
+  Int.equal (Context.Rel.length sign) (k + 1)
   &&
   noccur_between 1 (k+1) ccl
 
@@ -315,8 +322,8 @@ let is_nondep_branch c l =
   try
     (* FIXME: do better using tags from l *)
     let sign,ccl = decompose_lam_n_decls (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 *)
+    noccur_between 1 (Context.Rel.length sign) ccl
+  with e when CErrors.noncritical e -> (* Not eta-expanded or not reduced *)
     false
 
 let extract_nondep_branches test c b l =
@@ -511,14 +518,20 @@ let rec detype flags avoid env sigma t =
 	  else noparams ()
 
     | Evar (evk,cl) ->
-        let bound_to_itself_or_letin (id,b,_) c =
-          b != None ||
-	  try let n = List.index Name.equal (Name id) (fst env) in 
-	      isRelN n c
-	  with Not_found -> isVarId id c in
+        let bound_to_itself_or_letin decl c =
+          match decl with
+          | LocalDef _ -> true
+          | LocalAssum (id,_) ->
+	     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 id = match Evd.evar_ident evk sigma with
+          | None -> Evd.pr_evar_suggested_name evk sigma
+          | Some id -> id
+          in
           let l = Evd.evar_instance_array bound_to_itself_or_letin (Evd.find sigma evk) cl in
           let fvs,rels = List.fold_left (fun (fvs,rels) (_,c) -> match kind_of_term c with Rel n -> (fvs,Int.Set.add n rels) | Var id -> (Id.Set.add id fvs,rels) | _ -> (fvs,rels)) (Id.Set.empty,Int.Set.empty) l in
           let l = Evd.evar_instance_array (fun d c -> not !print_evar_arguments && (bound_to_itself_or_letin d c && not (isRel c && Int.Set.mem (destRel c) rels || isVar c && (Id.Set.mem (destVar c) fvs)))) (Evd.find sigma evk) cl in
@@ -607,7 +620,7 @@ and share_names flags n l avoid env sigma c t =
         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_warning (strbrk "Detyping.detype: cannot factorize fix enough");
+        if n>0 then Feedback.msg_debug (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)
@@ -618,7 +631,7 @@ and detype_eqns flags avoid env sigma ci computable constructs consnargsl bl =
     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 ->
+  with e when CErrors.noncritical e ->
     Array.to_list
       (Array.map3 (detype_eqn flags avoid env sigma) constructs consnargsl bl)
 
@@ -673,23 +686,36 @@ and detype_binder (lax,isgoal as flags) bk avoid env sigma na body ty c =
   match bk with
   | 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)
+  | BLetIn ->
+      let c = detype (lax,false) avoid env sigma (Option.get body) in
+      (* Heuristic: we display the type if in Prop *)
+      let s = try Retyping.get_sort_family_of (snd env) sigma ty with _ when !Flags.in_debugger || !Flags.in_toplevel -> InType (* Can fail because of sigma missing in debugger *) in
+      let c = if s != InProp then c else
+          GCast (dl, c, CastConv (detype (lax,false) avoid env sigma ty)) in
+      GLetIn (dl, na', c, r)
 
 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
   | [] -> []
-  | (na,b,t)::rest ->
+  | decl::rest ->
+      let open Context.Rel.Declaration in
+      let na = get_name decl in
+      let t = get_type decl in
       let na',avoid' =
 	match where with
 	| None -> na,avoid
 	| Some c ->
-	    if b != None then
+	    if is_local_def decl then
 	      compute_displayed_let_name_in
                 (RenamingElsewhereFor (fst env,c)) avoid na c
 	    else
 	      compute_displayed_name_in
                 (RenamingElsewhereFor (fst env,c)) avoid na c in
+      let b = match decl with
+	      | LocalAssum _ -> None
+	      | LocalDef (_,b,_) -> Some b
+      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
diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli
index 838588dc..c51cb0f4 100644
--- a/pretyping/detyping.mli
+++ b/pretyping/detyping.mli
@@ -8,7 +8,6 @@
 
 open Names
 open Term
-open Context
 open Environ
 open Glob_term
 open Termops
@@ -46,7 +45,7 @@ val detype_case :
 val detype_sort : evar_map -> sorts -> glob_sort
 
 val detype_rel_context : ?lax:bool -> constr option -> Id.t list -> (names_context * env) -> 
-  evar_map -> rel_context -> glob_decl list
+  evar_map -> Context.Rel.t -> glob_decl list
 
 val detype_closed_glob : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> closed_glob_constr -> glob_constr
 
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 637a9e50..9fd55a48 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -6,22 +6,25 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Term
 open Vars
-open Closure
+open CClosure
 open Reduction
 open Reductionops
 open Termops
 open Environ
 open Recordops
 open Evarutil
+open Evardefine
 open Evarsolve
 open Globnames
 open Evd
 open Pretype_errors
+open Sigma.Notations
+open Context.Rel.Declaration
 
 type unify_fun = transparent_state ->
   env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result
@@ -39,12 +42,7 @@ let _ = Goptions.declare_bool_option {
 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'
+      Some (mkProj (Projection.make cst true, c))
     else None
       
 let eval_flexible_term ts env evd c =
@@ -54,12 +52,15 @@ let eval_flexible_term ts env evd 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
-      with Not_found -> None)
+      (try match lookup_rel n env with
+           | LocalAssum _ -> None
+           | LocalDef (_,v,_) -> Some (lift n v)
+       with Not_found -> None)
   | Var id ->
       (try
 	 if is_transparent_variable ts id then
-	   let (_,v,_) = lookup_named id env in v
+           let open Context.Named.Declaration in
+	   lookup_named id env |> get_value
 	 else None
        with Not_found -> None)
   | LetIn (_,b,_,c) -> Some (subst1 b c)
@@ -96,21 +97,20 @@ let position_problem l2r = function
   | CONV -> None
   | CUMUL -> Some l2r
 
-let occur_rigidly ev evd t = 
-  let (l, app) = decompose_app_vect t in 
-  let rec aux t = 
+let occur_rigidly (evk,_ as ev) evd t =
+  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
+    | Evar (evk',_) -> if Evar.equal evk evk' 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
+    | Case (_,_,c,_) -> if eq_constr (mkEvar ev) c then raise Occur else false
+  in try ignore(aux t); false with Occur -> true
 
 (* [check_conv_record env sigma (t1,stack1) (t2,stack2)] tries to decompose 
    the problem (t1 stack1) = (t2 stack2) into a problem
@@ -138,6 +138,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) =
     try
       match kind_of_term t2 with
 	Prod (_,a,b) -> (* assert (l2=[]); *)
+	  let _, a, b = destProd (Evarutil.nf_evar sigma t2) in
       	  if dependent (mkRel 1) b then raise Not_found
 	  else lookup_canonical_conversion (proji, Prod_cs),
 	    (Stack.append_app [|a;pop b|] Stack.empty)
@@ -308,7 +309,7 @@ let exact_ise_stack2 env evd f sk1 sk2 =
   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
@@ -317,25 +318,22 @@ let rec evar_conv_x ts env evd pbty term1 term2 =
      Note: incomplete heuristic... *)
   let ground_test =
     if is_ground_term evd term1 && is_ground_term evd term2 then (
-      let evd, e = 
+      let e =
 	try
 	  let evd, b = infer_conv ~catch_incon:false ~pb:pbty ~ts:(fst ts)
 	    env evd term1 term2 
 	  in
-	    if b then evd, None
-	    else evd, Some (ConversionFailed (env,term1,term2))
-	with Univ.UniverseInconsistency e -> evd, Some (UnifUnivInconsistency e)
+	    if b then Success evd
+	    else UnifFailure (evd, ConversionFailed (env,term1,term2))
+	with Univ.UniverseInconsistency e -> UnifFailure (evd, UnifUnivInconsistency e)
       in
 	match e with
-	| None -> Some (evd, e)
-	| Some e -> 
-	  if is_ground_env evd env then Some (evd, Some e)
-	  else None)
+	| UnifFailure (evd, e) when not (is_ground_env evd env) -> None
+	| _ -> Some e)
     else None
   in
   match ground_test with
-    | Some (evd, None) -> Success evd
-    | Some (evd, Some e) -> UnifFailure (evd,e)
+    | Some result -> result
     | None ->
 	(* Until pattern-unification is used consistently, use nohdbeta to not
 	   destroy beta-redexes that can be used for 1st-order unification *)
@@ -364,8 +362,6 @@ let rec evar_conv_x ts env evd pbty term1 term2 =
 
 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
@@ -393,7 +389,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
     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 env' = push_rel (LocalAssum (na,c)) env in
     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
@@ -417,7 +413,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
     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
+      | None -> quick_fail evd
       | Some lF -> 
         let tM = Stack.zip apprM in
 	  miller_pfenning on_left
@@ -431,7 +427,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
       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))
+	     (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
@@ -448,7 +445,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
 		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)
+		    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') 
@@ -464,10 +462,11 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
   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)
+      match kind_of_term termR with
+      | Lambda _ when (* if ever problem is ill-typed: *) List.is_empty skR ->
+         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 ->
@@ -479,7 +478,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
 	      ise_try evd 
 	        [eta;(* Postpone the use of an heuristic *)
 		 (fun i -> 
-		   if not (occur_rigidly (fst ev) i tR) then
+		   if not (occur_rigidly ev i tR) then
                      let i,tF =
                        if isRel tR || isVar tR then
                          (* Optimization so as to generate candidates *)
@@ -497,15 +496,18 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
   (* Evar must be undefined since we have flushed evars *)
   let () = if !debug_unification then
 	     let open Pp in
-	     pp (v 0 (pr_state appr1 ++ cut () ++ pr_state appr2 ++ cut ()) 
+	     Feedback.msg_notice (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) ->
+        (* sk1[?ev1] =? sk2[?ev2] *)
 	let f1 i =
+          (* Try first-order unification *)
 	  match ise_stack2 false env i (evar_conv_x ts) sk1 sk2 with
-	  |None, Success i' -> 
-	    (* Evar can be defined in i' *)
+	  | None, Success i' ->
+            (* We do have sk1[] = sk2[]: we now unify ?ev1 and ?ev2 *)
+            (* Note that ?ev1 and ?ev2, may have been instantiated in the meantime *)
 	    let ev1' = whd_evar i' (mkEvar ev1) in
 	      if isEvar ev1' then
 		solve_simple_eqn (evar_conv_x ts) env i'
@@ -513,7 +515,9 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
 	      else 
 		evar_eqappr_x ts env evd pbty 
 		  ((ev1', sk1), csts1) ((term2, sk2), csts2)
-	  |Some (r,[]), Success i' -> 
+	  | Some (r,[]), Success i' ->
+            (* We have sk1'[] = sk2[] for some sk1' s.t. sk1[]=sk1'[r[]] *)
+            (* we now unify r[?ev1] and ?ev2 *)
 	    let ev2' = whd_evar i' (mkEvar ev2) in
 	      if isEvar ev2' then
 		solve_simple_eqn (evar_conv_x ts) env i'
@@ -521,16 +525,46 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
 	      else 
 		evar_eqappr_x ts env evd pbty 
 		  ((ev2', sk1), csts1) ((term2, sk2), csts2)
-
-	  |Some ([],r), Success i' -> 
+	  | Some ([],r), Success i' ->
+            (* Symmetrically *)
+            (* We have sk1[] = sk2'[] for some sk2' s.t. sk2[]=sk2'[r[]] *)
+            (* we now unify ?ev1 and r[?ev2] *)
 	    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)
+	  | None, (UnifFailure _ as x) ->
+             (* sk1 and sk2 have no common outer part *)
+             if Stack.not_purely_applicative sk2 then
+               (* Ad hoc compatibility with 8.4 which treated non-app as rigid *)
+               flex_rigid true ev1 appr1 appr2
+             else
+             if Stack.not_purely_applicative sk1 then
+               (* Ad hoc compatibility with 8.4 which treated non-app as rigid *)
+               flex_rigid false ev2 appr2 appr1
+             else
+               (* We could instead try Miller unification, then
+                  postpone to see if other equations help, as in:
+                  [Check fun a b : unit => (eqᵣefl : _ a = _ a b)] *)
+               x
+	  | Some _, Success _ ->
+             (* sk1 and sk2 have a common outer part *)
+             if Stack.not_purely_applicative sk2 then
+               (* Ad hoc compatibility with 8.4 which treated non-app as rigid *)
+               flex_rigid true ev1 appr1 appr2
+             else
+             if Stack.not_purely_applicative sk1 then
+               (* Ad hoc compatibility with 8.4 which treated non-app as rigid *)
+               flex_rigid false ev2 appr2 appr1
+             else
+               (* We could instead try Miller unification, then
+                  postpone to see if other equations help, as in:
+                  [Check fun a b c : unit => (eqᵣefl : _ a b = _ c a b)] *)
+               UnifFailure (i,NotSameArgSize)
+          | _, _ -> anomaly (Pp.str "Unexpected result from ise_stack2.")
+
 	and f2 i =
           if Evar.equal sp1 sp2 then
 	    match ise_stack2 false env i (evar_conv_x ts) sk1 sk2 with
@@ -553,14 +587,17 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
     | MaybeFlexible v1, MaybeFlexible v2 -> begin
         match kind_of_term term1, kind_of_term term2 with
         | LetIn (na1,b1,t1,c'1), LetIn (na2,b2,t2,c'2) ->
-        let f1 i =
+        let f1 i = (* FO *)
           ise_and i
-	    [(fun i -> evar_conv_x ts env i CONV b1 b2);
+            [(fun i -> ise_try i
+               [(fun i -> evar_conv_x ts env i CUMUL t1 t2);
+                (fun i -> evar_conv_x ts env i CUMUL t2 t1)]);
+             (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
                let na = Nameops.name_max na1 na2 in
-	       evar_conv_x ts (push_rel (na,Some b,t) env) i pbty c'1 c'2);
+	       evar_conv_x ts (push_rel (LocalDef (na,b,t)) env) i pbty c'1 c'2);
 	     (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)
@@ -675,7 +712,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
            (fun i ->
 	     let c = nf_evar i c1 in
              let na = Nameops.name_max na1 na2 in
-	     evar_conv_x ts (push_rel (na,None,c) env) i CONV c'1 c'2)]
+	     evar_conv_x ts (push_rel (LocalAssum (na,c)) env) i CONV c'1 c'2)]
 
     | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2
     | Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1
@@ -708,10 +745,10 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
 	  ise_try evd [f3; f4]
 
     (* Eta-expansion *)
-    | Rigid, _ when isLambda term1 ->
+    | Rigid, _ when isLambda term1 && (* if ever ill-typed: *) List.is_empty sk1 ->
         eta env evd true sk1 term1 sk2 term2
 
-    | _, Rigid when isLambda term2 ->
+    | _, Rigid when isLambda term2 && (* if ever ill-typed: *) List.is_empty sk2 ->
         eta env evd false sk2 term2 sk1 term1
 
     | Rigid, Rigid -> begin
@@ -726,7 +763,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
 	       in Success evd'
 	     with Univ.UniverseInconsistency p ->
                UnifFailure (evd,UnifUnivInconsistency p)
-	     | e when Errors.noncritical e -> UnifFailure (evd,NotSameHead))
+	     | e when CErrors.noncritical e -> UnifFailure (evd,NotSameHead))
 
 	| Prod (n1,c1,c'1), Prod (n2,c2,c'2) when app_empty ->
             ise_and evd
@@ -734,7 +771,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
                (fun i ->
  	         let c = nf_evar i c1 in
                  let na = Nameops.name_max n1 n2 in
-	         evar_conv_x ts (push_rel (na,None,c) env) i pbty c'1 c'2)]
+	         evar_conv_x ts (push_rel (LocalAssum (na,c)) env) i pbty c'1 c'2)]
 
 	| Rel x1, Rel x2 ->
 	    if Int.equal x1 x2 then
@@ -830,7 +867,9 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2)
 	      (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
+	    let i = Sigma.Unsafe.of_evar_map i in
+            let Sigma (ev, i', _) = Evarutil.new_evar env i ~src:dloc (substl ks b) in
+            let i' = Sigma.to_evar_map i' in
 	    (i', ev :: ks, m - 1,test))
 	(evd,[],List.length bs,fun i -> Success i) bs
     in
@@ -854,7 +893,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2)
 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 -> 
+    | Some (Some (id, projs, pbs)) when mib.Declarations.mind_finite == Decl_kinds.BiFinite -> 
       let pars = mib.Declarations.mind_nparams in
 	(try 
 	   let l1' = Stack.tail pars sk1 in
@@ -909,6 +948,7 @@ let choose_less_dependent_instance evk evd term args =
   | [] -> None
   | (id, _) :: _ -> Some (Evd.define evk (mkVar id) evd)
 
+open Context.Named.Declaration
 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 *)
@@ -919,7 +959,7 @@ let apply_on_subterm env evdref f c t =
       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 Option.is_empty b then applyrec acc a else a in
+          let g decl a = if is_local_assum decl 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
@@ -936,17 +976,17 @@ let filter_possible_projections c ty ctxt args =
   let fv2 = collect_vars (mkApp (c,args)) in
   let len = Array.length args in
   let tyvars = collect_vars ty in
-  List.map_i (fun i (id,b,_) ->
+  List.map_i (fun i decl ->
     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)) ||
+    (match decl with LocalAssum _ -> false | LocalDef (_,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 && Int.Set.mem (destRel a) fv1 ||
     isVar a && Id.Set.mem (destVar a) fv2 ||
-    Id.Set.mem id tyvars)
+    Id.Set.mem (get_id decl) tyvars)
     0 ctxt
 
 let solve_evars = ref (fun _ -> failwith "solve_evars not installed")
@@ -977,17 +1017,18 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
   let env_evar = evar_filtered_env evi in
   let sign = named_context_val env_evar in
   let ctxt = evar_filtered_context evi in
-  let instance = List.map mkVar (List.map pi1 ctxt) in
+  let instance = List.map mkVar (List.map get_id ctxt) in
 
   let rec make_subst = function
-  | (id,_,t)::ctxt', c::l, occs::occsl when isVarId id c ->
+  | decl'::ctxt', c::l, occs::occsl when isVarId (get_id decl') c ->
       begin match occs with
       | Some _ ->
         error "Cannot force abstraction on identity instance."
       | None ->
         make_subst (ctxt',l,occsl)
       end
-  | (id,_,t)::ctxt', c::l, occs::occsl ->
+  | decl'::ctxt', c::l, occs::occsl ->
+      let (id,_,t) = to_tuple decl' in
       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
@@ -1004,7 +1045,9 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
         | None ->
         let evty = set_holes evdref cty subst in
         let instance = Filter.filter_list filter instance in
-        let evd,ev = new_evar_instance sign !evdref evty ~filter instance in
+        let evd = Sigma.Unsafe.of_evar_map !evdref in
+        let Sigma (ev, evd, _) = new_evar_instance sign evd evty ~filter instance in
+        let evd = Sigma.to_evar_map evd in
         evdref := evd;
         evsref := (fst (destEvar ev),evty)::!evsref;
         ev in
@@ -1038,7 +1081,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
               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
+              match reconsider_unif_constraints (evar_conv_x ts) evd with
               | UnifFailure _ -> error "Cannot find an instance"
               | Success evd ->
               evd
@@ -1061,7 +1104,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
   abstract_free_holes evd subst, true
   with TypingFailed evd -> evd, false
 
-let second_order_matching_with_args ts env evd ev l t =
+let second_order_matching_with_args ts env evd pbty 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
@@ -1069,8 +1112,9 @@ let second_order_matching_with_args ts env evd ev l t =
   if b then Success evd
   else UnifFailure (evd, ConversionFailed (env,mkApp(mkEvar ev,l),t))
   if b then Success evd else
-*)
-  UnifFailure (evd, ConversionFailed (env,mkApp(mkEvar ev,l),t))
+ *)
+  let pb = (pbty,env,mkApp(mkEvar ev,l),t) in
+  UnifFailure (evd, CannotSolveConstraint (pb,ProblemBeyondCapabilities))
 
 let apply_conversion_problem_heuristic ts env evd pbty t1 t2 =
   let t1 = apprec_nohdbeta ts env evd (whd_head_evar evd t1) in
@@ -1086,7 +1130,9 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 =
          type inference *)
       (match choose_less_dependent_instance evk1 evd term2 args1 with
       | Some evd -> Success evd
-      | None -> UnifFailure (evd, ConversionFailed (env,term1,term2)))
+      | None ->
+         let reason = ProblemBeyondCapabilities in
+         UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason)))
   | (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) ->
@@ -1094,12 +1140,14 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 =
          type inference *)
       (match choose_less_dependent_instance evk2 evd term1 args2 with
       | Some evd -> Success evd
-      | None -> UnifFailure (evd, ConversionFailed (env,term1,term2)))
+      | None ->
+         let reason = ProblemBeyondCapabilities in
+         UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason)))
   | 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
+      let f env evd pbty x y = is_fconv ~reds:ts pbty 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 ->
+  | Evar ev1, Evar ev2 when app_empty ->
       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)
@@ -1109,27 +1157,32 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 =
       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 t2)]
+           second_order_matching_with_args ts env evd pbty 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 t1)]
+           second_order_matching_with_args ts env evd pbty ev2 l2 t1)]
   | Evar ev1,_ ->
       (* Try second-order pattern-matching *)
-      second_order_matching_with_args ts env evd ev1 l1 t2
+      second_order_matching_with_args ts env evd pbty ev1 l1 t2
   | _,Evar ev2 ->
       (* Try second-order pattern-matching *)
-      second_order_matching_with_args ts env evd ev2 l2 t1
+      second_order_matching_with_args ts env evd pbty ev2 l2 t1
   | _ ->
       (* Some head evar have been instantiated, or unknown kind of problem *)
       evar_conv_x ts env evd pbty t1 t2
 
+let error_cannot_unify env evd pb ?reason t1 t2 =
+  Pretype_errors.error_cannot_unify_loc
+    (loc_of_conv_pb evd pb) env
+    evd ?reason (t1, t2)
+
 let check_problems_are_solved env evd =
   match snd (extract_all_conv_pbs evd) with
-  | (pbty,env,t1,t2)::_ -> Pretype_errors.error_cannot_unify env evd (t1, t2)
+  | (pbty,env,t1,t2) as pb::_ -> error_cannot_unify env evd pb t1 t2
   | _ -> ()
 
 let max_undefined_with_candidates evd =
@@ -1160,7 +1213,7 @@ let rec solve_unconstrained_evars_with_candidates ts evd =
             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
-            match reconsider_conv_pbs conv_algo evd with
+            match reconsider_unif_constraints conv_algo evd with
             | Success evd -> solve_unconstrained_evars_with_candidates ts evd
             | UnifFailure _ -> aux l
           with
@@ -1174,16 +1227,16 @@ let rec solve_unconstrained_evars_with_candidates ts evd =
 let solve_unconstrained_impossible_cases env evd =
   Evd.fold_undefined (fun evk ev_info evd' ->
     match ev_info.evar_source with
-    | _,Evar_kinds.ImpossibleCase -> 
+    | loc,Evar_kinds.ImpossibleCase ->
       let j, ctx = coq_unit_judge () in
-      let evd' = Evd.merge_context_set Evd.univ_flexible_alg evd' ctx in
+      let evd' = Evd.merge_context_set Evd.univ_flexible_alg ~loc 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 env
+let solve_unif_constraints_with_heuristics 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 =
@@ -1198,23 +1251,23 @@ let consider_remaining_unif_problems env
 	      aux evd pbs progress (pb :: stuck)
             end
         | UnifFailure (evd,reason) ->
-	    Pretype_errors.error_cannot_unify_loc (loc_of_conv_pb evd pb)
-              env evd ~reason (t1, t2))
+           error_cannot_unify env evd pb ~reason t1 t2)
     | _ -> 
 	if progress then aux evd stuck false []
 	else 
 	  match stuck with
 	  | [] -> (* We're finished *) evd
 	  | (pbty,env,t1,t2 as pb) :: _ ->
-	      (* There remains stuck problems *)
-	      Pretype_errors.error_cannot_unify_loc (loc_of_conv_pb evd pb)
-                env evd (t1, t2)
+	     (* There remains stuck problems *)
+             error_cannot_unify env evd pb 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 env heuristic_solved_evd
 
+let consider_remaining_unif_problems = solve_unif_constraints_with_heuristics
+
 (* Main entry points *)
 
 exception UnableToUnify of evar_map * unification_error
diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli
index 14947c89..2231e5bc 100644
--- a/pretyping/evarconv.mli
+++ b/pretyping/evarconv.mli
@@ -33,7 +33,10 @@ val e_cumul : env -> ?ts:transparent_state -> evar_map ref -> constr -> constr -
 (** Try heuristics to solve pending unification problems and to solve
     evars with candidates *)
 
+val solve_unif_constraints_with_heuristics : env -> ?ts:transparent_state -> evar_map -> evar_map
+
 val consider_remaining_unif_problems : env -> ?ts:transparent_state -> evar_map -> evar_map
+(** @deprecated Alias for [solve_unif_constraints_with_heuristics] *)
 
 (** Check all pending unification problems are solved and raise an
     error otherwise *)
diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml
new file mode 100644
index 00000000..f9ab75ce
--- /dev/null
+++ b/pretyping/evardefine.ml
@@ -0,0 +1,207 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \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 Vars
+open Termops
+open Namegen
+open Environ
+open Evd
+open Evarutil
+open Pretype_errors
+open Sigma.Notations
+
+let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
+  let evd = Sigma.Unsafe.of_evar_map evd in
+  let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in
+  (Sigma.to_evar_map evd, evk)
+
+let env_nf_evar sigma env =
+  let open Context.Rel.Declaration in
+  process_rel_context
+    (fun d e -> push_rel (map_constr (nf_evar sigma) d) e) env
+
+let env_nf_betaiotaevar sigma env =
+  let open Context.Rel.Declaration in
+  process_rel_context
+    (fun d e ->
+      push_rel (map_constr (Reductionops.nf_betaiota sigma) d) e) env
+
+(****************************************)
+(* Operations on value/type constraints *)
+(****************************************)
+
+type type_constraint = types option
+
+type val_constraint = constr option
+
+(* Old comment...
+ * Basically, we have the following kind of constraints (in increasing
+ * strength order):
+ *   (false,(None,None)) -> no constraint at all
+ *   (true,(None,None))  -> we must build a judgement which _TYPE is a kind
+ *   (_,(None,Some ty))  -> we must build a judgement which _TYPE is ty
+ *   (_,(Some v,_))      -> we must build a judgement which _VAL is v
+ * Maybe a concrete datatype would be easier to understand.
+ * We differentiate (true,(None,None)) from (_,(None,Some Type))
+ * because otherwise Case(s) would be misled, as in
+ * (n:nat) Case n of bool [_]nat end  would infer the predicate Type instead
+ * of Set.
+ *)
+
+(* The empty type constraint *)
+let empty_tycon = None
+
+(* Builds a type constraint *)
+let mk_tycon ty = Some ty
+
+(* Constrains the value of a type *)
+let empty_valcon = None
+
+(* Builds a value constraint *)
+let mk_valcon c = Some c
+
+let idx = Namegen.default_dependent_ident
+
+(* Refining an evar to a product *)
+
+let define_pure_evar_as_product evd evk =
+  let open Context.Named.Declaration in
+  let evi = Evd.find_undefined evd evk in
+  let evenv = evar_env evi in
+  let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in
+  let concl = Reductionops.whd_all evenv evd evi.evar_concl in
+  let s = destSort concl in
+  let evd1,(dom,u1) =
+    let evd = Sigma.Unsafe.of_evar_map evd in
+    let Sigma (e, evd1, _) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in
+    (Sigma.to_evar_map evd1, e)
+  in
+  let evd2,rng =
+    let newenv = push_named (LocalAssum (id, dom)) evenv in
+    let src = evar_source evk evd1 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_unsafe newenv evd1 concl ~src ~filter
+      else
+	let status = univ_flexible_alg in
+	let evd3, (rng, srng) =
+          let evd1 = Sigma.Unsafe.of_evar_map evd1 in
+          let Sigma (e, evd3, _) = new_type_evar newenv evd1 status ~src ~filter in
+          (Sigma.to_evar_map evd3, e)
+        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
+
+(* Refine an applied evar to a product and returns its instantiation *)
+
+let define_evar_as_product evd (evk,args) =
+  let evd,prod = define_pure_evar_as_product evd evk in
+  (* 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 evrng =  mkEvar (fst (destEvar rng), evrngargs) in
+  evd,mkProd (na, evdom, evrng)
+
+(* Refine an evar with an abstraction
+
+   I.e., solve x1..xq |- ?e:T(x1..xq) with e:=λy:A.?e'[x1..xq,y] where:
+   - either T(x1..xq) = πy:A(x1..xq).B(x1..xq,y)
+     or T(x1..xq) = ?d[x1..xq] and we define ?d := πy:?A.?B
+        with x1..xq |- ?A:Type and x1..xq,y |- ?B:Type
+   - x1..xq,y:A |- ?e':B
+*)
+
+let define_pure_evar_as_lambda env evd evk =
+  let open Context.Named.Declaration in
+  let evi = Evd.find_undefined evd evk in
+  let evenv = evar_env evi in
+  let typ = Reductionops.whd_all evenv 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 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 (Reductionops.whd_evar evd dom) in
+  let newenv = push_named (LocalAssum (id, dom)) evenv in
+  let filter = Filter.extend 1 (evar_filter evi) in
+  let src = evar_source evk evd1 in
+  let evd2,body = new_evar_unsafe 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
+
+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 evbody = mkEvar (fst (destEvar body), evbodyargs) in
+  evd,mkLambda (na, dom, evbody)
+
+let rec evar_absorb_arguments env evd (evk,args as ev) = function
+  | [] -> evd,ev
+  | a::l ->
+      (* TODO: optimize and avoid introducing intermediate evars *)
+      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
+
+(* Refining an evar to a sort *)
+
+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 concl = Reductionops.whd_all (evar_env evi) evd evi.evar_concl in
+  let sort = destSort concl in
+  let evd' = Evd.define ev (mkSort s) evd in
+  Evd.set_leq_sort env evd' (Type (Univ.super u)) sort, 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 split_tycon loc env evd tycon =
+  let rec real_split evd c =
+    let t = Reductionops.whd_all env evd c in
+      match kind_of_term t with
+	| Prod (na,dom,rng) -> evd, (na, dom, rng)
+	| Evar ev (* ev is undefined because of whd_all *) ->
+	    let (evd',prod) = define_evar_as_product evd ev in
+	    let (_,dom,rng) = destProd prod in
+	      evd',(Anonymous, dom, rng)
+	| App (c,args) when isEvar c ->
+	    let (evd',lam) = define_evar_as_lambda env evd (destEvar c) in
+	    real_split evd' (mkApp (lam,args))
+	| _ -> error_not_product_loc loc env evd c
+  in
+    match tycon with
+      | None -> evd,(Anonymous,None,None)
+      | 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 -> Termops.print_constr_env env t
diff --git a/pretyping/evardefine.mli b/pretyping/evardefine.mli
new file mode 100644
index 00000000..07b0e69d
--- /dev/null
+++ b/pretyping/evardefine.mli
@@ -0,0 +1,46 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \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 Environ
+
+val env_nf_evar : evar_map -> env -> env
+val env_nf_betaiotaevar : evar_map -> env -> env
+
+type type_constraint = types option
+type val_constraint = constr option
+
+val empty_tycon : type_constraint
+val mk_tycon : constr -> type_constraint
+val empty_valcon : val_constraint
+val mk_valcon : constr -> val_constraint
+
+(** 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 split_tycon :
+  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_tycon : int -> type_constraint -> type_constraint
+
+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 : env -> evar_map -> existential -> evar_map * sorts
+
+(** {6 debug pretty-printer:} *)
+
+val pr_tycon : env -> type_constraint -> Pp.std_ppcmds
+
diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index 3bf6f376..4fd03084 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -7,11 +7,10 @@
 (************************************************************************)
 
 open Util
-open Errors
+open CErrors
 open Names
 open Term
 open Vars
-open Context
 open Environ
 open Termops
 open Evd
@@ -20,6 +19,7 @@ open Retyping
 open Reductionops
 open Evarutil
 open Pretype_errors
+open Sigma.Notations
 
 let normalize_evar evd ev =
   match kind_of_term (whd_evar evd (mkEvar ev)) with
@@ -42,28 +42,39 @@ let get_polymorphic_positions f =
         templ.template_param_levels)
   | _ -> assert false
 
-let refresh_level evd s =
-  match Evd.is_sort_variable evd s with
-  | None -> true
-  | Some l -> not (Evd.is_flexible_level evd l)
-
-let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) pbty env evd t =
+let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false)
+		      pbty env evd t =
   let evdref = ref evd in
   let modified = ref false in
-  let rec refresh status 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 && refresh_level evd s) ->
+  (* direction: true for fresh universes lower than the existing ones *)
+  let refresh_sort status ~direction s =
     let s' = evd_comb0 (new_sort_variable status) evdref in
     let evd = 
-      if dir then set_leq_sort env !evdref s' s
+      if direction then set_leq_sort env !evdref s' s
       else set_leq_sort env !evdref s s'
     in
-      modified := true; evdref := evd; mkSort s'
+    modified := true; evdref := evd; mkSort s'
+  in
+  let rec refresh ~onlyalg status ~direction t =
+    match kind_of_term t with
+    | Sort (Type u as s) ->
+       (match Univ.universe_level u with
+	| None -> refresh_sort status ~direction s
+	| Some l ->
+	   (match Evd.universe_rigidity evd l with
+	    | UnivRigid ->
+	       if not onlyalg then refresh_sort status ~direction s
+	       else t
+	    | UnivFlexible alg ->
+	       if onlyalg && alg then
+	         (evdref := Evd.make_flexible_variable !evdref false l; t)
+	       else t))
+    | Sort (Prop Pos as s) when refreshset && not direction ->
+       (* Cannot make a universe "lower" than "Set",
+          only refreshing when we want higher universes. *)
+       refresh_sort status ~direction s
     | Prod (na,u,v) -> 
-      mkProd (na,u,refresh status dir v)
+      mkProd (na, u, refresh ~onlyalg status ~direction v)
     | _ -> t
   (** Refresh the types of evars under template polymorphic references *)
   and refresh_term_evars onevars top t =
@@ -76,11 +87,11 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) pbty env evd t =
       Array.iter (refresh_term_evars onevars false) args
     | Evar (ev, a) when onevars ->
       let evi = Evd.find !evdref ev in
-      let ty' = refresh univ_flexible true evi.evar_concl in
+      let ty' = refresh ~onlyalg univ_flexible ~direction: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 false) t
+    | _ -> Constr.iter (refresh_term_evars onevars false) t
   and refresh_polymorphic_positions args pos =
     let rec aux i = function
       | Some l :: ls -> 
@@ -96,9 +107,11 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) pbty env evd t =
   in
   let t' = 
     if isArity t then
-      (match pbty with
-      | None -> t
-      | Some dir -> refresh status dir t)
+      match pbty with
+      | None ->
+	 (* No cumulativity needed, but we still need to refresh the algebraics *)
+	 refresh ~onlyalg:true univ_flexible ~direction:false t
+      | Some direction -> refresh ~onlyalg status ~direction t
     else (refresh_term_evars false true t; t)
   in
     if !modified then !evdref, t' else !evdref, t
@@ -140,7 +153,7 @@ let recheck_applications conv_algo env evdref t =
        let argsty = Array.map (fun x -> aux env x; Retyping.get_type_of env !evdref x) args in
        let rec aux i ty =
 	 if i < Array.length argsty then
-	 match kind_of_term (whd_betadeltaiota env !evdref ty) with
+	 match kind_of_term (whd_all env !evdref ty) with
 	 | Prod (na, dom, codom) ->
 	    (match conv_algo env !evdref Reduction.CUMUL argsty.(i) dom with
 	     | Success evd -> evdref := evd;
@@ -163,7 +176,8 @@ type 'a update =
 | UpdateWith of 'a
 | NoUpdate
 
-let inst_of_vars sign = Array.map_of_list (fun (id,_,_) -> mkVar id) sign
+open Context.Named.Declaration
+let inst_of_vars sign = Array.map_of_list (mkVar % get_id) sign
 
 let restrict_evar_key evd evk filter candidates =
   match filter, candidates with
@@ -181,7 +195,9 @@ let restrict_evar_key evd evk filter candidates =
       let candidates = match candidates with
       | NoUpdate -> evi.evar_candidates
       | UpdateWith c -> Some c in
-      restrict_evar evd evk filter candidates
+      let sigma = Sigma.Unsafe.of_evar_map evd in
+      let Sigma (evk, sigma, _) = restrict_evar sigma evk filter candidates in
+      (Sigma.to_evar_map sigma, evk)
     end
 
 (* Restrict an applied evar and returns its restriction in the same context *)
@@ -206,32 +222,32 @@ let restrict_instance evd evk filter argsv =
   let evi = Evd.find evd evk in
   Filter.filter_array (Filter.compose (evar_filter evi) filter) argsv
 
+open Context.Rel.Declaration
 let noccur_evar env evd evk c =
   let cache = ref Int.Set.empty (* cache for let-ins *) in
-  let rec occur_rec (k, env as acc) c =
+  let rec occur_rec check_types (k, env as acc) c =
   match kind_of_term c with
   | Evar (evk',args' as ev') ->
       (match safe_evar_value evd ev' with
-       | Some c -> occur_rec acc c
+       | Some c -> occur_rec check_types acc c
        | None ->
            if Evar.equal evk evk' then raise Occur
-           else Array.iter (occur_rec acc) args')
+           else (if check_types then
+                   occur_rec false acc (existential_type evd ev');
+                 Array.iter (occur_rec check_types acc) args'))
   | Rel i when i > k ->
-      if not (Int.Set.mem (i-k) !cache) then
-      (match pi2 (Environ.lookup_rel i env) with
-       | None -> ()
-       | Some b -> cache := Int.Set.add (i-k) !cache; occur_rec acc (lift i b))
-  | Proj (p,c) -> 
-    let c = 
-      try Retyping.expand_projection env evd p c []
-      with Retyping.RetypeError _ -> 
-	(* Can happen when called from w_unify which doesn't assign evars/metas 
-	   eagerly enough *) c
-    in occur_rec acc c
+     if not (Int.Set.mem (i-k) !cache) then
+       let decl = Environ.lookup_rel i env in
+       if check_types then
+         (cache := Int.Set.add (i-k) !cache; occur_rec false acc (lift i (get_type decl)));
+       (match decl with
+        | LocalAssum _ -> ()
+        | LocalDef (_,b,_) -> cache := Int.Set.add (i-k) !cache; occur_rec false acc (lift i b))
+  | Proj (p,c) -> occur_rec true acc c
   | _ -> iter_constr_with_full_binders (fun rd (k,env) -> (succ k, push_rel rd env))
-    occur_rec acc c
+    (occur_rec check_types) acc c
   in
-  try occur_rec (0,env) c; true with Occur -> false
+  try occur_rec false (0,env) c; true with Occur -> false
 
 (***************************************)
 (* Managing chains of local definitons *)
@@ -242,9 +258,11 @@ let noccur_evar env evd evk c =
    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 ->
+  let open Context.Named.Declaration in
+  List.fold_right (fun decl aliases ->
+    let id = get_id decl in
+    match decl with
+    | LocalDef (_,t,_) ->
         (match kind_of_term t with
         | Var id' ->
             let aliases_of_id =
@@ -252,27 +270,30 @@ let compute_var_aliases sign =
             Id.Map.add id (aliases_of_id@[t]) aliases
         | _ ->
             Id.Map.add id [t] aliases)
-    | None -> aliases)
+    | LocalAssum _ -> aliases)
     sign Id.Map.empty
 
 let compute_rel_aliases var_aliases rels =
-  snd (List.fold_right (fun (_,b,u) (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 (mkCast(t,DEFAULTcast,u))] aliases)
-     | None -> aliases))
-         rels (List.length rels,Int.Map.empty))
+  snd (List.fold_right
+	 (fun decl (n,aliases) ->
+	  (n-1,
+	   match decl with
+	   | LocalDef (_,t,u) ->
+	      (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 (mkCast(t,DEFAULTcast,u))] aliases)
+	   | LocalAssum _ -> aliases)
+	 )
+	 rels
+	 (List.length rels,Int.Map.empty))
 
 let make_alias_map env =
   (* We compute the chain of aliases for each var and rel *)
@@ -306,13 +327,13 @@ let normalize_alias aliases 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 extend_alias decl (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 decl with
+    | LocalDef(_,t,_) ->
         (match kind_of_term t with
         | Var id' ->
             let aliases_of_binder =
@@ -324,7 +345,7 @@ let extend_alias (_,b,_) (var_aliases,rel_aliases) =
             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
+    | LocalAssum _ -> rel_aliases in
   (var_aliases, rel_aliases)
 
 let expand_alias_once aliases x =
@@ -430,16 +451,17 @@ let get_actual_deps aliases l t =
       | Rel n -> Int.Set.mem n fv_rels
       | _ -> assert false) l
 
+open Context.Named.Declaration
 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 ->
+  | LocalAssum _ :: sign ->
     let () = assert (i < len) in
     (Array.unsafe_get args i) :: aux sign (succ i)
-  | (_, Some _, _) :: sign ->
+  | LocalDef _ :: sign ->
     aux sign (succ i)
   in
   aux (evar_filtered_context evi) 0
@@ -501,7 +523,8 @@ let solve_pattern_eqn env l c =
     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
+          let open Context.Rel.Declaration in
+          let d = map_constr (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'
@@ -509,7 +532,7 @@ let solve_pattern_eqn env l c =
     l c in
   (* Warning: we may miss some opportunity to eta-reduce more since c'
      is not in normal form *)
-  whd_eta c'
+  shrink_eta c'
 
 (*****************************************)
 (* Refining/solving unification problems *)
@@ -530,9 +553,9 @@ let make_projectable_subst aliases sigma evi args =
   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 ->
+      (fun decl (args,all,cstrs) ->
+        match decl,args with
+        | LocalAssum (id,c), a::rest ->
             let a = whd_evar sigma a in
             let cstrs =
               let a',args = decompose_app_vect a in
@@ -542,7 +565,7 @@ let make_projectable_subst aliases sigma evi args =
                   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 ->
+        | LocalDef (id,c,_), a::rest ->
             let a = whd_evar sigma a in
             (match kind_of_term c with
             | Var id' ->
@@ -571,7 +594,9 @@ let make_projectable_subst aliases sigma evi args =
  *)
 
 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 evd = Sigma.Unsafe.of_evar_map evd in
+  let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in
+  let evd = Sigma.to_evar_map evd 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
@@ -596,16 +621,24 @@ let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_si
  * substitution u1..uq.
  *)
 
+exception MorePreciseOccurCheckNeeeded
+
 let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
+  if Evd.is_defined evd evk1 then
+      (* Some circularity somewhere (see e.g. #3209) *)
+      raise MorePreciseOccurCheckNeeeded;
+  let (evk1,args1) = destEvar (whd_evar evd (mkEvar (evk1,args1))) in
   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 ids1 = List.map get_id (named_context_of_val sign1) in
   let inst_in_sign = List.map mkVar (Filter.filter_list filter1 ids1) in
+  let open Context.Rel.Declaration 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) ->
+    List.fold_right (fun d (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) ->
+      let LocalAssum (na,t_in_env) | LocalDef (na,_,t_in_env) = d in
       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
@@ -613,13 +646,13 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
 	 ~status:univ_flexible (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_in_sign = match d with
+      | LocalAssum _ -> evd,None
+      | LocalDef (_,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,
+      (push_named_context_val (Context.Named.Declaration.of_tuple (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))
@@ -632,8 +665,10 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
      ~status:univ_flexible (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 =
+  let evd = Sigma.Unsafe.of_evar_map evd in
+  let Sigma (ev2_in_sign, evd, _) =
     new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in
+  let evd = Sigma.to_evar_map evd in
   let ev2_in_env = (fst (destEvar ev2_in_sign), Array.of_list inst2_in_env) in
   (evd, ev2_in_sign, ev2_in_env)
 
@@ -757,9 +792,10 @@ let project_with_effects aliases sigma effects t subst =
   effects := p :: !effects;
   c
 
+open Context.Named.Declaration
 let rec find_solution_type evarenv = function
-  | (id,ProjectVar)::l -> pi3 (lookup_named id evarenv)
-  | [id,ProjectEvar _] -> (* bugged *) pi3 (lookup_named id evarenv)
+  | (id,ProjectVar)::l -> get_type (lookup_named id evarenv)
+  | [id,ProjectEvar _] -> (* bugged *) get_type (lookup_named id evarenv)
   | (id,ProjectEvar _)::l -> find_solution_type evarenv l
   | [] -> assert false
 
@@ -779,7 +815,7 @@ let rec do_projection_effects define_fun env ty evd = function
       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
+      let ty = whd_all 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
@@ -893,7 +929,7 @@ let invert_invertible_arg fullenv evd aliases k (evk,argsv) args' =
  *)
 
 let set_of_evctx l =
-  List.fold_left (fun s (id,_,_) -> Id.Set.add id s) Id.Set.empty l
+  List.fold_left (fun s decl -> Id.Set.add (get_id decl) s) Id.Set.empty l
 
 let filter_effective_candidates evi filter candidates =
   match filter with
@@ -925,7 +961,13 @@ let closure_of_filter evd evk = function
   | 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 test b decl = b || Idset.mem (get_id decl) vars ||
+                    match decl with
+                    | LocalAssum _ ->
+                       false
+                    | LocalDef (_,c,_) ->
+                       not (isRel c || isVar c)
+  in
   let newfilter = Filter.map_along test filter (evar_context evi) in
   (* Now ensure that restriction is at least what is was originally *)
   let newfilter = Option.cata (Filter.map_along (&&) newfilter) newfilter (Filter.repr (evar_filter evi)) in
@@ -1007,21 +1049,6 @@ let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs =
  * 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
@@ -1296,7 +1323,7 @@ let occur_evar_upto_types sigma n c =
          seen := Evar.Set.add sp !seen;
 	 Option.iter occur_rec (existential_opt_value sigma e);
 	 occur_rec (existential_type sigma e))
-    | _ -> iter_constr occur_rec c
+    | _ -> Constr.iter occur_rec c
   in
   try occur_rec c; false with Occur -> true
 
@@ -1381,15 +1408,16 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs =
     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 ->
+        let open Context.Rel.Declaration in
+        (match Environ.lookup_rel (i-k) env' with
+        | LocalAssum _ -> project_variable (mkRel (i-k))
+        | LocalDef (_,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 ->
+        (match Environ.lookup_named id env' with
+        | LocalAssum _ -> project_variable t
+        | LocalDef (_,b,_) ->
           try project_variable t
           with NotInvertibleUsingOurAlgorithm _ -> imitate envk b)
     | LetIn (na,b,u,c) ->
@@ -1450,7 +1478,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs =
                   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
+              with e when CErrors.noncritical e -> l in
             (match candidates with
             | [x] -> x
             | _ ->
@@ -1469,7 +1497,8 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs =
     let names = ref Idset.empty in
     let rec is_id_subst ctxt s =
       match ctxt, s with
-      | ((id, _, _) :: ctxt'), (c :: s') ->
+      | (decl :: ctxt'), (c :: s') ->
+        let id = get_id decl in
         names := Idset.add id !names;
         isVarId id c && is_id_subst ctxt' s'
       | [], [] -> true
@@ -1538,11 +1567,13 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs =
         postpone_non_unique_projection env evd pbty ev sols rhs
     | NotEnoughInformationEvarEvar t ->
         add_conv_oriented_pb (pbty,env,mkEvar ev,t) evd
+    | MorePreciseOccurCheckNeeeded ->
+        add_conv_oriented_pb (pbty,env,mkEvar ev,rhs) 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
+        let c = whd_all 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')
@@ -1580,7 +1611,7 @@ 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 reconsider_unif_constraints 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) ->
@@ -1593,6 +1624,8 @@ let reconsider_conv_pbs conv_algo evd =
     (Success evd)
     pbs
 
+let reconsider_conv_pbs = reconsider_unif_constraints
+
 (* Tries to solve problem t1 = t2.
  * Precondition: t1 is an uninstantiated evar
  * Returns an optional list of evars that were instantiated, or None
@@ -1603,7 +1636,7 @@ let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1)
   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
+      reconsider_unif_constraints conv_algo evd
   with
     | NotInvertibleUsingOurAlgorithm t ->
         UnifFailure (evd,NotClean (ev1,env,t))
diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli
index 918ba12f..b6bdc078 100644
--- a/pretyping/evarsolve.mli
+++ b/pretyping/evarsolve.mli
@@ -34,8 +34,12 @@ type conv_fun_bool =
 val evar_define : conv_fun -> ?choose:bool -> env -> evar_map -> 
   bool option -> existential -> constr -> evar_map
 
-val refresh_universes : ?status:Evd.rigid ->
-			?onlyalg:bool (* Only algebraic universes *) ->
+val refresh_universes :
+  ?status:Evd.rigid ->
+  ?onlyalg:bool (* Only algebraic universes *) ->
+  ?refreshset:bool ->
+  (* Also refresh Prop and Set universes, so that the returned type can be any supertype
+     of the original type *)
   bool option (* direction: true for levels lower than the existing levels *) ->
   env -> evar_map -> types -> evar_map * types
 
@@ -50,7 +54,10 @@ val solve_evar_evar : ?force:bool ->
 val solve_simple_eqn : conv_fun -> ?choose:bool -> env ->  evar_map ->
   bool option * existential * constr -> unification_result
 
+val reconsider_unif_constraints : conv_fun -> evar_map -> unification_result
+
 val reconsider_conv_pbs : conv_fun -> evar_map -> unification_result
+(** @deprecated Alias for [reconsider_unif_constraints] *)
 
 val is_unification_pattern_evar : env -> evar_map -> existential -> constr list ->
   constr -> constr list option
diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml
index 6733b7fc..4caa1e99 100644
--- a/pretyping/find_subterm.ml
+++ b/pretyping/find_subterm.ml
@@ -8,7 +8,7 @@
 
 open Pp
 open Util
-open Errors
+open CErrors
 open Names
 open Locus
 open Term
@@ -59,19 +59,22 @@ let proceed_with_occurrences f occs 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 ->
+let map_named_declaration_with_hyploc f hyploc acc decl =
+  let open Context.Named.Declaration in
+  let f = f (Some (get_id decl, hyploc)) in
+  match decl,hyploc with
+  | LocalAssum (id,_), 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 ->
+  | LocalAssum (id,typ), _ ->
+      let acc,typ = f acc typ in acc, LocalAssum (id,typ)
+  | LocalDef (id,body,typ), InHypTypeOnly ->
+      let acc,typ = f acc typ in acc, LocalDef (id,body,typ)
+  | LocalDef (id,body,typ), InHypValueOnly ->
+      let acc,body = f acc body in acc, LocalDef (id,body,typ)
+  | LocalDef (id,body,typ), InHyp ->
       let acc,body = f acc body in
       let acc,typ = f acc typ in
-      acc,(id,Some body,typ)
+      acc, LocalDef (id,body,typ)
 
 (** Finding a subterm up to some testing function *)
 
@@ -105,7 +108,6 @@ let replace_term_occ_gen_modulo occs like_first test bywhat cl occ t =
      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
diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli
index 28108f8c..c741ab04 100644
--- a/pretyping/find_subterm.mli
+++ b/pretyping/find_subterm.mli
@@ -7,7 +7,6 @@
 (************************************************************************)
 
 open Locus
-open Context
 open Term
 open Evd
 open Pretype_errors
@@ -50,7 +49,7 @@ val replace_term_occ_modulo : occurrences or_like_first ->
 val replace_term_occ_decl_modulo :
   (occurrences * hyp_location_flag) or_like_first ->
   'a testing_function -> (unit -> constr) ->
-  named_declaration -> named_declaration
+  Context.Named.Declaration.t -> Context.Named.Declaration.t
 
 (** [subst_closed_term_occ occl c d] replaces occurrences of
     closed [c] at positions [occl] by [Rel 1] in [d] (see also Note OCC),
@@ -62,7 +61,7 @@ val subst_closed_term_occ : env -> evar_map -> occurrences or_like_first ->
     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
+  constr -> Context.Named.Declaration.t -> Context.Named.Declaration.t * evar_map
 
 (** Miscellaneous *)
 val error_invalid_occurrence : int list -> 'a
diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml
index c9860864..51660818 100644
--- a/pretyping/glob_ops.ml
+++ b/pretyping/glob_ops.ml
@@ -266,7 +266,7 @@ let add_name_to_ids set na =
     | Anonymous -> set
     | Name id -> Id.Set.add id set
 
-let free_glob_vars  =
+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)
@@ -324,10 +324,24 @@ let free_glob_vars  =
     let vs = vars Id.Set.empty Id.Set.empty rt in
     Id.Set.elements vs
 
+let glob_visible_short_qualid c =
+  let rec aux acc = function
+    | GRef (_,c,_) ->
+        let qualid = Nametab.shortest_qualid_of_global Id.Set.empty c in
+        let dir,id = Libnames.repr_qualid  qualid in
+        if DirPath.is_empty dir then id :: acc else acc
+    | c ->
+        fold_glob_constr aux acc c
+  in aux [] c
+
+let warn_variable_collision =
+  let open Pp in
+  CWarnings.create ~name:"variable-collision" ~category:"ltac"
+         (fun name ->
+          strbrk "Collision between bound variables of name " ++ pr_id name)
+
 let add_and_check_ident id set =
-  if Id.Set.mem id set then
-    Pp.(msg_warning
-      (str "Collision between bound variables of name " ++ Id.print id));
+  if Id.Set.mem id set then warn_variable_collision id;
   Id.Set.add id set
 
 let bound_glob_vars =
@@ -456,6 +470,78 @@ let loc_of_glob_constr = function
   | GCast (loc,_,_) -> loc
 
 (**********************************************************************)
+(* Alpha-renaming                                                     *)
+
+let collide_id l id = List.exists (fun (id',id'') -> Id.equal id id' || Id.equal id id'') l
+let test_id l id = if collide_id l id then raise Not_found
+let test_na l na = name_iter (test_id l) na
+
+let update_subst na l =
+  let in_range id l = List.exists (fun (_,id') -> Id.equal id id') l in
+  let l' = name_fold Id.List.remove_assoc na l in
+  name_fold
+    (fun id _ ->
+     if in_range id l' then
+       let id' = Namegen.next_ident_away_from id (fun id' -> in_range id' l') in
+       Name id', (id,id')::l
+     else na,l)
+    na (na,l)
+
+exception UnsoundRenaming
+
+let rename_var l id =
+  try
+    let id' = Id.List.assoc id l in
+    (* Check that no other earlier binding hide the one found *)
+    let _,(id'',_) = List.extract_first (fun (_,id) -> Id.equal id id') l in
+    if Id.equal id id'' then id' else raise UnsoundRenaming
+  with Not_found ->
+    if List.exists (fun (_,id') -> Id.equal id id') l then raise UnsoundRenaming
+    else id
+
+let rec rename_glob_vars l = function
+  | GVar (loc,id) as r ->
+      let id' = rename_var l id in
+      if id == id' then r else GVar (loc,id')
+  | GRef (_,VarRef id,_) as r ->
+      if List.exists (fun (_,id') -> Id.equal id id') l then raise UnsoundRenaming
+      else r
+  | GProd (loc,na,bk,t,c) ->
+      let na',l' = update_subst na l in
+      GProd (loc,na,bk,rename_glob_vars l t,rename_glob_vars l' c)
+  | GLambda (loc,na,bk,t,c) ->
+      let na',l' = update_subst na l in
+      GLambda (loc,na',bk,rename_glob_vars l t,rename_glob_vars l' c)
+  | GLetIn (loc,na,b,c) ->
+      let na',l' = update_subst na l in
+      GLetIn (loc,na',rename_glob_vars l b,rename_glob_vars l' c)
+  (* Lazy strategy: we fail if a collision with renaming occurs, rather than renaming further *)
+  | GCases (loc,ci,po,tomatchl,cls) ->
+      let test_pred_pat (na,ino) =
+        test_na l na; Option.iter (fun (_,_,nal) -> List.iter (test_na l) nal) ino in
+      let test_clause idl = List.iter (test_id l) idl in
+      let po = Option.map (rename_glob_vars l) po in
+      let tomatchl = Util.List.map_left (fun (tm,x) -> test_pred_pat x; (rename_glob_vars l tm,x)) tomatchl in
+      let cls = Util.List.map_left (fun (loc,idl,p,c) -> test_clause idl; (loc,idl,p,rename_glob_vars l c)) cls in
+      GCases (loc,ci,po,tomatchl,cls)
+  | GLetTuple (loc,nal,(na,po),c,b) ->
+     List.iter (test_na l) (na::nal);
+     GLetTuple (loc,nal,(na,Option.map (rename_glob_vars l) po),
+                rename_glob_vars l c,rename_glob_vars l b)
+  | GIf (loc,c,(na,po),b1,b2) ->
+     test_na l na;
+     GIf (loc,rename_glob_vars l c,(na,Option.map (rename_glob_vars l) po),
+          rename_glob_vars l b1,rename_glob_vars l b2)
+  | GRec (loc,k,idl,decls,bs,ts) ->
+     Array.iter (test_id l) idl;
+     GRec (loc,k,idl,
+           Array.map (List.map (fun (na,k,bbd,bty) ->
+             test_na l na; (na,k,Option.map (rename_glob_vars l) bbd,rename_glob_vars l bty))) decls,
+           Array.map (rename_glob_vars l) bs,
+           Array.map (rename_glob_vars l) ts)
+  | r -> map_glob_constr (rename_glob_vars l) r
+
+(**********************************************************************)
 (* Conversion from glob_constr to cases pattern, if possible            *)
 
 let rec cases_pattern_of_glob_constr na = function
diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli
index 45444234..55e6b653 100644
--- a/pretyping/glob_ops.mli
+++ b/pretyping/glob_ops.mli
@@ -34,12 +34,25 @@ val map_glob_constr :
 val map_glob_constr_left_to_right :
   (glob_constr -> glob_constr) -> glob_constr -> glob_constr
 
+val warn_variable_collision : ?loc:Loc.t -> Id.t -> unit
+
 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 bound_glob_vars : glob_constr -> Id.Set.t
 val loc_of_glob_constr : glob_constr -> Loc.t
+val glob_visible_short_qualid : glob_constr -> Id.t list
+
+(* Renaming free variables using a renaming map; fails with
+   [UnsoundRenaming] if applying the renaming would introduce
+   collision, as in, e.g., renaming [P x y] using substitution [(x,y)];
+   inner alpha-conversion done only for forall, fun, let but
+   not for cases and fix *)
+
+exception UnsoundRenaming
+val rename_var : (Id.t * Id.t) list -> Id.t -> Id.t
+val rename_glob_vars : (Id.t * Id.t) list -> glob_constr -> glob_constr
 
 (** [map_pattern_binders f m c] applies [f] to all the binding names
     in a pattern-matching expression ({!Glob_term.GCases}) represented
diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
index d5f6e9b3..39aeb41f 100644
--- a/pretyping/indrec.ml
+++ b/pretyping/indrec.ml
@@ -11,7 +11,7 @@
 (* This file builds various inductive schemes *)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Libnames
@@ -19,7 +19,6 @@ open Globnames
 open Nameops
 open Term
 open Vars
-open Context
 open Namegen
 open Declarations
 open Declareops
@@ -28,6 +27,8 @@ open Inductiveops
 open Environ
 open Reductionops
 open Nametab
+open Sigma.Notations
+open Context.Rel.Declaration
 
 type dep_flag = bool
 
@@ -35,12 +36,14 @@ type dep_flag = bool
 type recursion_scheme_error =
   | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * pinductive
   | NotMutualInScheme of inductive * inductive
+  | NotAllowedDependentAnalysis of (*isrec:*) bool * 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)
 
+
 (*******************************************)
 (* Building curryfied elimination          *)
 (*******************************************)
@@ -60,7 +63,7 @@ let check_privacy_block mib =
 
 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 indf = make_ind_family(pind, Context.Rel.to_extended_list 0 lnamespar) in
   let constrs = get_constructors env indf in
   let projs = get_projections env indf in
 
@@ -77,7 +80,6 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
   (* mais pas très joli ... (mais manque get_sort_of à ce niveau) *)
   let env' = push_rel_context lnamespar env in
 
-
   let rec add_branch env k =
     if Int.equal k (Array.length mip.mind_consnames) then
       let nbprod = k+1 in
@@ -85,14 +87,14 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
       let indf' = lift_inductive_family nbprod indf in
       let arsign,_ = get_arity env indf' in
       let depind = build_dependent_inductive env indf' in
-      let deparsign = (Anonymous,None,depind)::arsign in
+      let deparsign = LocalAssum (Anonymous,depind)::arsign in
 
       let ci = make_case_info env (fst pind) RegularStyle in
       let pbody =
         appvect
           (mkRel (ndepar + nbprod),
-           if dep then Termops.extended_rel_vect 0 deparsign
-           else Termops.extended_rel_vect 1 arsign) in
+           if dep then Context.Rel.to_extended_vect 0 deparsign
+           else Context.Rel.to_extended_vect 1 arsign) in
       let p =
 	it_mkLambda_or_LetIn_name env'
 	  ((if dep then mkLambda_name env' else mkLambda)
@@ -118,15 +120,16 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
       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))
+	(add_branch (push_rel (LocalAssum (Anonymous, t)) env) (k+1))
   in
-  let sigma, s = Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in
+  let Sigma (s, sigma, p) = Sigma.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
-  in sigma, c
+     (add_branch (push_rel (LocalAssum (Anonymous,typP)) env') 0)) lnamespar
+  in
+  Sigma (c, sigma, p)
 
 (* check if the type depends recursively on one of the inductive scheme *)
 
@@ -150,23 +153,26 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
   let nparams = List.length vargs in
   let process_pos env depK pk =
     let rec prec env i sign p =
-      let p',largs = whd_betadeltaiota_nolet_stack env sigma p in
+      let p',largs = whd_allnolet_stack env sigma p in
       match kind_of_term p' with
 	| Prod (n,t,c) ->
-	    let d = (n,None,t) in
+	    let d = LocalAssum (n,t) in
 	    make_prod env (n,t,prec (push_rel d env) (i+1) (d::sign) c)
-	| LetIn (n,b,t,c) ->
-	    let d = (n,Some b,t) in
+	| LetIn (n,b,t,c) when List.is_empty largs ->
+	    let d = LocalDef (n,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 base = applist (lift i pk,realargs) in
             if depK then
 	      Reduction.beta_appvect
-                base [|applist (mkRel (i+1), Termops.extended_rel_list 0 sign)|]
+                base [|applist (mkRel (i+1), Context.Rel.to_extended_list 0 sign)|]
             else
 	      base
-      	| _ -> assert false
+      	| _ ->
+	   let t' = whd_all env sigma p in
+	   if Term.eq_constr p' t' then assert false
+	   else prec env i sign t'
     in
     prec env 0 []
   in
@@ -179,31 +185,29 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
               | ra::rest ->
                   (match dest_recarg ra with
 	            | Mrec (_,j) when is_rec -> (depPvect.(j),rest)
-	            | Imbr _  ->
-		        msg_warning (strbrk "Ignoring recursive call");
-		        (None,rest)
+	            | Imbr _  -> (None,rest)
                     | _ -> (None, rest))
 	  in
           (match optionpos with
 	     | None ->
 		 make_prod env
 		   (n,t,
-		    process_constr (push_rel (n,None,t) env) (i+1) c_0 rest
+		    process_constr (push_rel (LocalAssum (n,t)) env) (i+1) c_0 rest
 		      (nhyps-1) (i::li))
              | Some(dep',p) ->
 		 let nP = lift (i+1+decP) p in
-                 let env' = push_rel (n,None,t) env in
+                 let env' = push_rel (LocalAssum (n,t)) env in
 		 let t_0 = process_pos env' dep' nP (lift 1 t) in
 		 make_prod_dep (dep || dep') env
                    (n,t,
 		    mkArrow t_0
 		      (process_constr
-			(push_rel (Anonymous,None,t_0) env')
+			(push_rel (LocalAssum (Anonymous,t_0)) env')
 			 (i+2) (lift 1 c_0) rest (nhyps-1) (i::li))))
       | LetIn (n,b,t,c_0) ->
 	  mkLetIn (n,b,t,
 		   process_constr
-		     (push_rel (n,Some b,t) env)
+		     (push_rel (LocalDef (n,b,t)) env)
 		     (i+1) c_0 recargs (nhyps-1) li)
       | _ -> assert false
     else
@@ -225,25 +229,28 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
 let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
   let process_pos env fk  =
     let rec prec env i hyps p =
-      let p',largs = whd_betadeltaiota_nolet_stack env sigma p in
+      let p',largs = whd_allnolet_stack env sigma p in
       match kind_of_term p' with
 	| Prod (n,t,c) ->
-	    let d = (n,None,t) in
+	    let d = LocalAssum (n,t) in
 	    mkLambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c)
-	| LetIn (n,b,t,c) ->
-	    let d = (n,Some b,t) in
+	| LetIn (n,b,t,c) when List.is_empty largs ->
+	    let d = LocalDef (n,b,t) in
 	    mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c)
      	| Ind _ ->
             let realargs = List.skipn nparrec largs
-            and arg = appvect (mkRel (i+1), Termops.extended_rel_vect 0 hyps) in
+            and arg = appvect (mkRel (i+1), Context.Rel.to_extended_vect 0 hyps) in
             applist(lift i fk,realargs@[arg])
-     	| _ -> assert false
+     	| _ ->
+	   let t' = whd_all env sigma p in
+	     if Term.eq_constr t' p' then assert false
+	     else prec env i hyps t'
     in
     prec env 0 []
   in
   (* 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 ->
+    | (LocalAssum (n,t) as d)::cprest, recarg::rest ->
         let optionpos =
 	  match dest_recarg recarg with
             | Norec   -> None
@@ -264,7 +271,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
 		 (n,t,process_constr env' (i+1)
 		    (whd_beta Evd.empty (applist (lift 1 f, [(mkRel 1); arg])))
 		    (cprest,rest)))
-    | (n,Some c,t as d)::cprest, rest ->
+    | (LocalDef (n,c,t) as d)::cprest, rest ->
 	mkLetIn
 	  (n,c,t,
 	   process_constr (push_rel d env) (i+1) (lift 1 f)
@@ -275,24 +282,13 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
   in
   process_constr env 0 f (List.rev cstr.cs_args, recargs)
 
-
-(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k
-   variables *)
-let context_chop k ctx =
-  let rec chop_aux acc = function
-    | (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)
-    | (_, []) -> failwith "context_chop"
-  in chop_aux [] (k,ctx)
-
 (* Main function *)
 let mis_make_indrec env sigma listdepkind mib u =
   let nparams = mib.mind_nparams in
   let nparrec = mib.mind_nparams_rec in
   let evdref = ref sigma in
   let lnonparrec,lnamesparrec =
-    context_chop (nparams-nparrec) (Vars.subst_instance_context u mib.mind_params_ctxt) in
+    Termops.context_chop (nparams-nparrec) (Vars.subst_instance_context u mib.mind_params_ctxt) in
   let nrec = List.length listdepkind in
   let depPvec =
     Array.make mib.mind_ntypes (None : (bool * constr) option) in
@@ -321,29 +317,29 @@ let mis_make_indrec env sigma listdepkind mib u =
 
             (* 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 args = Context.Rel.to_extended_list (nrec+nbconstruct) lnamesparrec 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
-	    let deparsign = (Anonymous,None,depind)::arsign in
+	    let deparsign = LocalAssum (Anonymous,depind)::arsign in
 
-	    let nonrecpar = rel_context_length lnonparrec in
-	    let larsign = rel_context_length deparsign in
+	    let nonrecpar = Context.Rel.length lnonparrec in
+	    let larsign = Context.Rel.length deparsign in
 	    let ndepar = larsign - nonrecpar in
 	    let dect = larsign+nrec+nbconstruct in
 
             (* constructors in context of the Cases expr, i.e.
                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 args' = Context.Rel.to_extended_list (dect+nrec) lnamesparrec in
+	    let args'' = Context.Rel.to_extended_list ndepar lnonparrec in
             let indf' = make_ind_family((indi,u),args'@args'') in
 
 	    let branches =
 	      let constrs = get_constructors env indf' in
 	      let fi = Termops.rel_vect (dect-i-nctyi) nctyi in
 	      let vecfi = Array.map
-		(fun f -> appvect (f, Termops.extended_rel_vect ndepar lnonparrec))
+		(fun f -> appvect (f, Context.Rel.to_extended_vect ndepar lnonparrec))
 		fi
 	      in
 		Array.map3
@@ -361,12 +357,12 @@ let mis_make_indrec env sigma listdepkind mib u =
 
 	    let depind' = build_dependent_inductive env indf' in
 	    let arsign',_ = get_arity env indf' in
-	    let deparsign' = (Anonymous,None,depind')::arsign' in
+	    let deparsign' = LocalAssum (Anonymous,depind')::arsign' in
 
 	    let pargs =
-	      let nrpar = Termops.extended_rel_list (2*ndepar) lnonparrec
-	      and nrar = if dep then Termops.extended_rel_list 0 deparsign'
-		else Termops.extended_rel_list 1 arsign'
+	      let nrpar = Context.Rel.to_extended_list (2*ndepar) lnonparrec
+	      and nrar = if dep then Context.Rel.to_extended_list 0 deparsign'
+		else Context.Rel.to_extended_list 1 arsign'
 	      in nrpar@nrar
 
 	    in
@@ -381,25 +377,9 @@ let mis_make_indrec env sigma listdepkind mib u =
 		      (Anonymous,depind',concl))
 		  arsign'
 	      in
-	      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
+	      let obj =
+		Inductiveops.make_case_or_project env indf ci pred
+						  (mkRel 1) branches
 	      in
 		it_mkLambda_or_LetIn_name env obj
 		  (Termops.lift_rel_context nrec deparsign)
@@ -409,14 +389,14 @@ let mis_make_indrec env sigma listdepkind mib u =
 
 	    let typtyi =
 	      let concl =
-		let pargs = if dep then Termops.extended_rel_vect 0 deparsign
-		  else Termops.extended_rel_vect 1 arsign
+		let pargs = if dep then Context.Rel.to_extended_vect 0 deparsign
+		  else Context.Rel.to_extended_vect 1 arsign
 		in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs)
 	      in it_mkProd_or_LetIn_name env
 		concl
 		deparsign
 	    in
-	      mrec (i+nctyi) (rel_context_nhyps arsign ::ln) (typtyi::ltyp)
+	      mrec (i+nctyi) (Context.Rel.nhyps arsign ::ln) (typtyi::ltyp)
                 (deftyi::ldef) rest
         | [] ->
 	    let fixn = Array.of_list (List.rev ln) in
@@ -437,28 +417,28 @@ let mis_make_indrec env sigma listdepkind mib u =
 	    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 vargs = Context.Rel.to_extended_list (nrec+i+j) lnamesparrec in
 	      let cs = get_constructor ((indi,u),mibi,mipi,vargs) (j+1) in
 	      let p_0 =
 		type_rec_branch
                   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))
+		  (onerec (push_rel (LocalAssum (Anonymous,p_0)) env) (j+1))
 	  in onerec env 0
       | [] ->
 	  makefix i listdepkind
     in
     let rec put_arity env i = function
       | ((indi,u),_,_,dep,kinds)::rest ->
-	  let indf = make_ind_family ((indi,u), Termops.extended_rel_list i lnamesparrec) in
+	  let indf = make_ind_family ((indi,u), Context.Rel.to_extended_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)
+	      (put_arity (push_rel (LocalAssum (Anonymous,typP)) env) (i+1) rest)
       | [] ->
 	  make_branch env 0 listdepkind
     in
@@ -474,7 +454,9 @@ let mis_make_indrec env sigma listdepkind mib u =
 	  it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind)
 	    lnamesparrec
       else
-	let evd', c = mis_make_case_com dep env !evdref (indi,u) (mibi,mipi) kind in
+        let sigma = Sigma.Unsafe.of_evar_map !evdref in
+        let Sigma (c, sigma, _) = mis_make_case_com dep env sigma (indi,u) (mibi,mipi) kind in
+        let evd' = Sigma.to_evar_map sigma in
 	  evdref := evd'; c
   in
     (* Body of mis_make_indrec *)
@@ -485,6 +467,8 @@ let mis_make_indrec env sigma listdepkind mib u =
 
 let build_case_analysis_scheme env sigma pity dep kind =
   let (mib,mip) = lookup_mind_specif env (fst pity) in
+  if dep && not (Inductiveops.has_dependent_elim mib) then
+    raise (RecursionSchemeError (NotAllowedDependentAnalysis (false, fst pity)));
   mis_make_case_com dep env sigma pity (mib,mip) kind
 
 let is_in_prop mip =
@@ -494,7 +478,7 @@ let is_in_prop mip =
 
 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
+  let dep = not (is_in_prop mip || not (Inductiveops.has_dependent_elim mib)) in
   mis_make_case_com dep env sigma pity (mib,mip) kind
 
 (**********************************************************************)
@@ -555,6 +539,8 @@ let check_arities env listdepkind =
 let build_mutual_induction_scheme env sigma = function
   | ((mind,u),dep,s)::lrecspec ->
       let (mib,mip) = lookup_mind_specif env mind in
+      if dep && not (Inductiveops.has_dependent_elim mib) then
+        raise (RecursionSchemeError (NotAllowedDependentAnalysis (true, mind)));
       let (sp,tyi) = mind in
       let listdepkind =
 	((mind,u),mib,mip,dep,s)::
@@ -574,6 +560,8 @@ let build_mutual_induction_scheme env sigma = function
 
 let build_induction_scheme env sigma pind dep kind =
   let (mib,mip) = lookup_mind_specif env (fst pind) in
+  if dep && not (Inductiveops.has_dependent_elim mib) then
+    raise (RecursionSchemeError (NotAllowedDependentAnalysis (true, fst pind)));
   let sigma, l = mis_make_indrec env sigma [(pind,mib,mip,dep,kind)] mib (snd pind) in
     sigma, List.hd l
 
@@ -592,7 +580,7 @@ let make_elimination_ident id s = add_suffix id (elimination_suffix s)
 
 let lookup_eliminator ind_sp s =
   let kn,i = ind_sp in
-  let mp,dp,l = repr_mind kn in
+  let mp,dp,l = KerName.repr (MutInd.canonical kn) in
   let ind_id = (Global.lookup_mind kn).mind_packets.(i).mind_typename in
   let id = add_suffix ind_id (elimination_suffix s) in
   (* Try first to get an eliminator defined in the same section as the *)
diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli
index 4d81a59e..192b64a5 100644
--- a/pretyping/indrec.mli
+++ b/pretyping/indrec.mli
@@ -16,6 +16,7 @@ open Evd
 type recursion_scheme_error =
   | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * pinductive
   | NotMutualInScheme of inductive * inductive
+  | NotAllowedDependentAnalysis of (*isrec:*) bool * inductive
 
 exception RecursionSchemeError of recursion_scheme_error
 
@@ -25,16 +26,18 @@ type dep_flag = bool
 
 (** Build a case analysis elimination scheme in some sort family *)
 
-val build_case_analysis_scheme : env -> evar_map -> pinductive ->
-      dep_flag -> sorts_family -> evar_map * constr
+val build_case_analysis_scheme : env -> 'r Sigma.t -> pinductive ->
+      dep_flag -> sorts_family -> (constr, 'r) Sigma.sigma
 
-(** Build a dependent case elimination predicate unless type is in Prop *)
+(** Build a dependent case elimination predicate unless type is in Prop
+   or is a recursive record with primitive projections. *)
 
-val build_case_analysis_scheme_default : env -> evar_map -> pinductive ->
-      sorts_family -> evar_map * constr
+val build_case_analysis_scheme_default : env -> 'r Sigma.t -> pinductive ->
+      sorts_family -> (constr, 'r) Sigma.sigma
 
 (** Builds a recursive induction scheme (Peano-induction style) in the same
-   sort family as the inductive family; it is dependent if not in Prop *)
+   sort family as the inductive family; it is dependent if not in Prop
+   or a recursive record with primitive projections.  *)
 
 val build_induction_scheme : env -> evar_map -> pinductive ->
       dep_flag -> sorts_family -> evar_map * constr
diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index fb180b8b..214e19fe 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -6,18 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Univ
 open Term
 open Vars
-open Context
 open Termops
 open Declarations
 open Declareops
 open Environ
 open Reductionops
+open Context.Rel.Declaration
 
 (* The following three functions are similar to the ones defined in
    Inductive, but they expect an env *)
@@ -142,12 +142,12 @@ let constructor_nallargs_env env ((kn,i),j) =
 
 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)
+  mip.mind_consnrealdecls.(j-1) + Context.Rel.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
-  mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt)
+  mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt)
 
 (* Arity of constructors excluding params, excluding local defs *)
 
@@ -213,21 +213,21 @@ let inductive_nparams_env env ind =
 
 let inductive_nparamdecls ind =
   let (mib,mip) = Global.lookup_inductive ind in
-  rel_context_length mib.mind_params_ctxt
+  Context.Rel.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
+  Context.Rel.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
+  Context.Rel.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_nrealdecls
+  Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls
 
 (* Others *)
 
@@ -249,13 +249,13 @@ let inductive_alldecls_env env (ind,u) =
 
 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 l1 = mip.mind_consnrealdecls.(j-1) + Context.Rel.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 l1 = Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls in
   let l2 = mib.mind_nparams + mip.mind_nrealargs in
   not (Int.equal l1 l2)
 
@@ -269,15 +269,20 @@ let projection_nparams_env env p =
 
 let projection_nparams p = projection_nparams_env (Global.env ()) p
 
+let has_dependent_elim mib =
+  match mib.mind_record with
+  | Some (Some _) -> mib.mind_finite == Decl_kinds.BiFinite
+  | _ -> true
+
 (* Annotation for cases *)
 let make_case_info env ind style =
   let (mib,mip) = Inductive.lookup_mind_specif env ind in
   let ind_tags =
-    rel_context_tags (List.firstn mip.mind_nrealdecls mip.mind_arity_ctxt) in
+    Context.Rel.to_tags (List.firstn mip.mind_nrealdecls 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))
+      Context.Rel.to_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;
@@ -292,7 +297,7 @@ type constructor_summary = {
   cs_cstr : pconstructor;
   cs_params : constr list;
   cs_nargs : int;
-  cs_args : rel_context;
+  cs_args : Context.Rel.t;
   cs_concl_realargs : constr array
 }
 
@@ -303,21 +308,15 @@ let lift_constructor n cs = {
   cs_args = lift_rel_context n cs.cs_args;
   cs_concl_realargs = Array.map (liftn n (cs.cs_nargs+1)) cs.cs_concl_realargs
 }
-(* Accept less parameters than in the signature *)
-
-let instantiate_params t args sign =
-  let rec inst s t = function
-    | ((_,None,_)::ctxt,a::args) ->
-	(match kind_of_term t with
-	   | Prod(_,_,t) -> inst (a::s) t (ctxt,args)
-	   | _ -> 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 ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch"))
-    | _, [] -> substl s t
-    | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch")
-  in inst [] t (List.rev sign,args)
+
+(* Accept either all parameters or only recursively uniform ones *)
+let instantiate_params t params sign =
+  let nnonrecpar = Context.Rel.nhyps sign - List.length params in
+  (* Adjust the signature if recursively non-uniform parameters are not here *)
+  let _,sign = context_chop nnonrecpar sign in
+  let _,t = decompose_prod_n_assum (Context.Rel.length sign) t in
+  let subst = subst_of_rel_context_instance sign params in
+  substl subst t
 
 let get_constructor ((ind,u as indu),mib,mip,params) j =
   assert (j <= Array.length mip.mind_consnames);
@@ -329,7 +328,7 @@ let get_constructor ((ind,u as indu),mib,mip,params) 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_nargs = Context.Rel.length args;
     cs_args = args;
     cs_concl_realargs = Array.of_list vargs }
 
@@ -344,6 +343,35 @@ let get_projections env (ind,params) =
     | Some (Some (id, projs, pbs)) -> Some projs
     | _ -> None
 
+let make_case_or_project env indf ci pred c branches =
+  let projs = get_projections env indf in
+  match projs with
+  | None -> (mkCase (ci, pred, c, branches))
+  | Some ps ->
+     assert(Array.length branches == 1);
+     let () =
+       let _, _, t = destLambda pred in
+       let (ind, _), _ = dest_ind_family indf in
+       let mib, _ = Inductive.lookup_mind_specif env ind in
+       if (* dependent *) not (noccurn 1 t) &&
+          not (has_dependent_elim mib) then
+       errorlabstrm "make_case_or_project"
+		    Pp.(str"Dependent case analysis not allowed" ++
+		     str" on inductive type " ++ Names.MutInd.print (fst ind))
+     in
+     let branch = branches.(0) in
+     let ctx, br = decompose_lam_n_assum (Array.length ps) branch in
+     let n, subst =
+       List.fold_right
+         (fun decl (i, subst) ->
+	  match decl with
+	  | LocalAssum (na, t) ->
+	     let t = mkProj (Projection.make ps.(i) true, c) in
+	     (i + 1, t :: subst)
+	  | LocalDef (na, b, t) -> (i, substl subst b :: subst))
+	 ctx (0, [])
+     in substl subst br
+
 (* substitution in a signature *)
 
 let substnl_rel_context subst n sign =
@@ -354,14 +382,6 @@ let substnl_rel_context subst n sign =
 
 let substl_rel_context subst = substnl_rel_context subst 0
 
-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 (Pp.str "Signature/instance mismatch in inductive family")
-  in aux [] (List.rev sign,args)
-
 let get_arity env ((ind,u),params) =
   let (mib,mip) = Inductive.lookup_mind_specif env ind in
   let parsign =
@@ -379,7 +399,7 @@ let get_arity env ((ind,u),params) =
   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 subst = instantiate_context parsign params in
+  let subst = subst_of_rel_context_instance parsign params in
   let arsign = Vars.subst_instance_context u arsign in
   (substl_rel_context subst arsign, Inductive.inductive_sort_family mip)
 
@@ -388,14 +408,14 @@ let build_dependent_constructor cs =
   applist
     (mkConstructU cs.cs_cstr,
      (List.map (lift cs.cs_nargs) cs.cs_params)
-      @(extended_rel_list 0 cs.cs_args))
+      @(Context.Rel.to_extended_list 0 cs.cs_args))
 
 let build_dependent_inductive env ((ind, params) as indf) =
   let arsign,_ = get_arity env indf in
   let nrealargs = List.length arsign in
   applist
     (mkIndU ind,
-     (List.map (lift nrealargs) params)@(extended_rel_list 0 arsign))
+     (List.map (lift nrealargs) params)@(Context.Rel.to_extended_list 0 arsign))
 
 (* builds the arity of an elimination predicate in sort [s] *)
 
@@ -404,7 +424,7 @@ let make_arity_signature env dep indf =
   if dep then
     (* We need names everywhere *)
     Namegen.name_context env
-      ((Anonymous,None,build_dependent_inductive env indf)::arsign)
+      ((LocalAssum (Anonymous,build_dependent_inductive env indf))::arsign)
       (* Costly: would be better to name once for all at definition time *)
   else
     (* No need to enforce names *)
@@ -430,14 +450,17 @@ let extract_mrectype t =
     | Ind ind -> (ind, l)
     | _ -> raise Not_found
 
-let find_mrectype env sigma c =
-  let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+let find_mrectype_vect env sigma c =
+  let (t, l) = decompose_appvect (whd_all env sigma c) in
   match kind_of_term t with
     | Ind ind -> (ind, l)
     | _ -> raise Not_found
 
+let find_mrectype env sigma c =
+  let (ind, v) = find_mrectype_vect env sigma c in (ind, Array.to_list v)
+
 let find_rectype env sigma c =
-  let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+  let (t, l) = decompose_app (whd_all env sigma c) in
   match kind_of_term t with
     | Ind (ind,u as indu) ->
         let (mib,mip) = Inductive.lookup_mind_specif env ind in
@@ -447,7 +470,7 @@ let find_rectype env sigma c =
     | _ -> raise Not_found
 
 let find_inductive env sigma c =
-  let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+  let (t, l) = decompose_app (whd_all env sigma c) in
   match kind_of_term t with
     | Ind ind
         when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite <> Decl_kinds.CoFinite ->
@@ -455,7 +478,7 @@ let find_inductive env sigma c =
     | _ -> raise Not_found
 
 let find_coinductive env sigma c =
-  let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+  let (t, l) = decompose_app (whd_all env sigma c) in
   match kind_of_term t with
     | Ind ind
         when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite == Decl_kinds.CoFinite ->
@@ -469,9 +492,9 @@ let find_coinductive env sigma c =
 
 let is_predicate_explicitly_dep env pred arsign =
   let rec srec env pval arsign =
-    let pv' = whd_betadeltaiota env Evd.empty pval in
+    let pv' = whd_all env Evd.empty pval in
     match kind_of_term pv', arsign with
-      | Lambda (na,t,b), (_,None,_)::arsign ->
+      | Lambda (na,t,b), (LocalAssum _)::arsign ->
 	  srec (push_rel_assum (na,t) env) b arsign
       | Lambda (na,_,t), _ ->
 
@@ -517,7 +540,7 @@ let set_pattern_names env ind brv =
   let arities =
     Array.map
       (fun c ->
-        rel_context_length ((prod_assum c)) -
+        Context.Rel.length ((prod_assum c)) -
         mib.mind_nparams)
       mip.mind_nf_lc in
   Array.map2 (set_names env) arities brv
@@ -529,7 +552,7 @@ let type_case_branches_with_names env indspec p c =
   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.betazeta_appvect (mip.mind_nrealdecls+1) p (Array.of_list (realargs@[c])) in
+  let conclty = lambda_appvect_assum (mip.mind_nrealdecls+1) p (Array.of_list (realargs@[c])) in
   (* Adjust names *)
   if is_elim_predicate_explicitly_dependent env p (ind,params) then
     (set_pattern_names env (fst ind) lbrty, conclty)
@@ -551,11 +574,11 @@ let arity_of_case_predicate env (ind,params) dep k =
    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 evdref scl is = function
-  | (_,Some _,_ as d)::sign, exp ->
+  | (LocalDef _ as d)::sign, exp ->
       d :: instantiate_universes env evdref scl is (sign, exp)
   | d::sign, None::exp ->
       d :: instantiate_universes env evdref scl is (sign, exp)
-  | (na,None,ty)::sign, Some l::exp ->
+  | (LocalAssum (na,ty))::sign, Some l::exp ->
       let ctx,_ = Reduction.dest_arity env ty in
       let u = Univ.Universe.make l in
       let s =
@@ -569,7 +592,7 @@ let rec instantiate_universes env evdref scl is = function
 	  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)
+      (LocalAssum (na,mkArity(ctx,s))) :: instantiate_universes env evdref scl is (sign, exp)
   | sign, [] -> sign (* Uniform parameters are exhausted *)
   | [], _ -> assert false
 
@@ -603,9 +626,9 @@ let type_of_projection_knowing_arg env sigma p c ty =
 let control_only_guard env c =
   let check_fix_cofix e c = match kind_of_term c with
     | CoFix (_,(_,_,_) as cofix) ->
-	Inductive.check_cofix e cofix
+      Inductive.check_cofix e cofix
     | Fix (_,(_,_,_) as fix) ->
-	Inductive.check_fix e fix
+      Inductive.check_fix e fix
     | _ -> ()
   in
   let rec iter env c =
diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli
index 7cd2ff2a..7bd61659 100644
--- a/pretyping/inductiveops.mli
+++ b/pretyping/inductiveops.mli
@@ -8,7 +8,6 @@
 
 open Names
 open Term
-open Context
 open Declarations
 open Environ
 open Evd
@@ -92,12 +91,12 @@ val inductive_nparamdecls : inductive -> int
 val inductive_nparamdecls_env : env -> inductive -> int
 
 (** @return params context *)
-val inductive_paramdecls : pinductive -> rel_context
-val inductive_paramdecls_env : env -> pinductive -> rel_context
+val inductive_paramdecls : pinductive -> Context.Rel.t
+val inductive_paramdecls_env : env -> pinductive -> Context.Rel.t
 
 (** @return full arity context, hence with letin *)
-val inductive_alldecls : pinductive -> rel_context
-val inductive_alldecls_env : env -> pinductive -> rel_context
+val inductive_alldecls : pinductive -> Context.Rel.t
+val inductive_alldecls_env : env -> pinductive -> Context.Rel.t
 
 (** {7 Extract information from a constructor name} *)
 
@@ -123,19 +122,24 @@ val inductive_has_local_defs : inductive -> bool
 
 val allowed_sorts : env -> inductive -> sorts_family list
 
+(** (Co)Inductive records with primitive projections do not have eta-conversion,
+    hence no dependent elimination. *)
+val has_dependent_elim : mutual_inductive_body -> bool
+
 (** Primitive projections *)
 val projection_nparams : projection -> int
 val projection_nparams_env : env -> projection -> int
 val type_of_projection_knowing_arg : env -> evar_map -> Projection.t ->
-  constr -> types -> types
+				     constr -> types -> types
+
 
 (** Extract information from an inductive family *)
 
 type constructor_summary = {
   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) *)
+  cs_params : constr list;   (* parameters of the constructor in current ctx *)
+  cs_nargs : int;            (* length of arguments signature (letin included) *)
+  cs_args : Context.Rel.t;   (* signature of the arguments (letin included) *)
   cs_concl_realargs : constr array; (* actual realargs in the concl of cstr *)
 }
 val lift_constructor : int -> constructor_summary -> constructor_summary
@@ -148,17 +152,18 @@ val get_projections  : env -> inductive_family -> constant array option
 (** [get_arity] returns the arity of the inductive family instantiated
     with the parameters; if recursively non-uniform parameters are not
     part of the inductive family, they appears in the arity *)
-val get_arity        : env -> inductive_family -> rel_context * sorts_family
+val get_arity        : env -> inductive_family -> Context.Rel.t * sorts_family
 
 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_signature : env -> bool -> inductive_family -> Context.Rel.t
 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 a valid inductive type *)
 val extract_mrectype : constr -> pinductive * constr list
 val find_mrectype    : env -> evar_map -> types -> pinductive * constr list
+val find_mrectype_vect : env -> evar_map -> types -> pinductive * constr array
 val find_rectype     : env -> evar_map -> types -> inductive_type
 val find_inductive   : env -> evar_map -> types -> pinductive * constr list
 val find_coinductive : env -> evar_map -> types -> pinductive * constr list
@@ -175,6 +180,14 @@ val type_case_branches_with_names :
 (** Annotation for cases *)
 val make_case_info : env -> inductive -> case_style -> case_info
 
+(** Make a case or substitute projections if the inductive type is a record
+    with primitive projections.
+    Fail with an error if the elimination is dependent while the
+    inductive type does not allow dependent elimination. *)
+val make_case_or_project :
+  env -> inductive_family -> case_info ->
+  (* pred *) constr -> (* term *) constr -> (* branches *) constr array -> constr
+
 (*i Compatibility
 val make_default_case_info : env -> case_style -> inductive -> case_info
 i*)
diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml
index d89aeccd..e4fbf8d5 100644
--- a/pretyping/locusops.ml
+++ b/pretyping/locusops.ml
@@ -50,9 +50,9 @@ let is_nowhere = function
 
 let simple_clause_of enum_hyps cl =
   let error_occurrences () =
-    Errors.error "This tactic does not support occurrences selection" in
+    CErrors.error "This tactic does not support occurrences selection" in
   let error_body_selection () =
-    Errors.error "This tactic does not support body selection" in
+    CErrors.error "This tactic does not support body selection" in
   let hyps =
     match cl.onhyps with
     | None ->
@@ -84,7 +84,7 @@ let concrete_clause_of enum_hyps cl =
 (** Miscellaneous functions *)
 
 let out_arg = function
-  | Misctypes.ArgVar _ -> Errors.anomaly (Pp.str "Unevaluated or_var variable")
+  | Misctypes.ArgVar _ -> CErrors.anomaly (Pp.str "Unevaluated or_var variable")
   | Misctypes.ArgArg x -> x
 
 let occurrences_of_hyp id cls =
diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml
index 6d09d569..0dd64697 100644
--- a/pretyping/nativenorm.ml
+++ b/pretyping/nativenorm.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 open Pp
-open Errors
+open CErrors
 open Term
 open Vars
 open Environ
@@ -18,7 +18,7 @@ open Inductive
 open Util
 open Nativecode
 open Nativevalues
-open Nativelambda
+open Context.Rel.Declaration
 
 (** This module implements normalization by evaluation to OCaml code *)
 
@@ -35,13 +35,13 @@ let invert_tag cst tag reloc_tbl =
   with Find_at j -> (j+1)
 
 let decompose_prod env t =
-  let (name,dom,codom as res) = destProd (whd_betadeltaiota env t) in
+  let (name,dom,codom as res) = destProd (whd_all 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
+  let t = whd_all env c in
   try destApp t with DestKO -> (t,[||])
 
  
@@ -121,9 +121,8 @@ let build_case_type dep 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_rel env n =
+  lookup_rel n env |> get_type |> lift n
 
 let type_of_prop = mkSort type1_sort
 
@@ -132,8 +131,9 @@ let type_of_sort s =
   | 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
+let type_of_var env id =
+  let open Context.Named.Declaration in
+  try lookup_named id env |> get_type
   with Not_found ->
     anomaly ~label:"type_of_var" (str "variable " ++ Id.print id ++ str " unbound")
 
@@ -178,10 +178,10 @@ let rec nf_val env v typ =
       let name,dom,codom = 
 	try decompose_prod env typ
 	with DestKO ->
-          Errors.anomaly
+          CErrors.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 env = push_rel (LocalAssum (name,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
@@ -224,7 +224,7 @@ and nf_args env accu t =
     let _,dom,codom =
       try decompose_prod env t with
 	DestKO ->
-	Errors.anomaly
+	CErrors.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
@@ -241,7 +241,7 @@ and nf_bargs env b t =
       let _,dom,codom =
 	try decompose_prod env !t with
 	  DestKO ->
-	  Errors.anomaly
+	  CErrors.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
@@ -257,7 +257,7 @@ and nf_atom env atom =
   | 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 env = push_rel (LocalAssum (n,dom)) env in
       let codom = nf_type env (codom vn) in
       mkProd(n,dom,codom)
   | Ameta (mv,_) -> mkMeta mv
@@ -289,7 +289,7 @@ and nf_atom_type env atom =
       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 pT = whd_all 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 u params dep p in
@@ -328,7 +328,7 @@ and nf_atom_type env atom =
   | 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 env = push_rel (LocalAssum (n,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) ->
@@ -352,11 +352,11 @@ and  nf_predicate env ind mip params v pT =
       let name,dom,codom =
 	try decompose_prod env pT with
 	  DestKO ->
-	  Errors.anomaly
+	  CErrors.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
+	nf_predicate (push_rel (LocalAssum (name,dom)) env) ind mip params vb codom in
       dep, mkLambda(name,dom,body)
   | Vfun f, _ -> 
       let k = nb_rel env in
@@ -366,7 +366,7 @@ and  nf_predicate env ind mip params v pT =
       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
+      let body = nf_type (push_rel (LocalAssum (name,dom)) env) vb in
       true, mkLambda(name,dom,body)
   | _, _ -> false, nf_type env v
 
@@ -389,16 +389,16 @@ let native_norm env sigma c ty =
   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 ...");
+        if !Flags.debug then Feedback.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);
+        if !Flags.debug then Feedback.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);
+        if !Flags.debug then Feedback.msg_debug (Pp.str time_info);
         res
     | _ -> anomaly (Pp.str "Compilation failure") 
 
diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli
index bbda55f4..0b1ce8e5 100644
--- a/pretyping/nativenorm.mli
+++ b/pretyping/nativenorm.mli
@@ -8,7 +8,6 @@
 open Term
 open Environ
 open Evd
-open Nativelambda
 
 (** This module implements normalization by evaluation to OCaml code *)
 
diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml
index af46c390..fe73b610 100644
--- a/pretyping/patternops.ml
+++ b/pretyping/patternops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Globnames
@@ -123,6 +123,7 @@ let head_of_constr_reference c = match kind_of_term c with
 
 let pattern_of_constr env sigma t =
   let rec pattern_of_constr env t =
+  let open Context.Rel.Declaration in
   match kind_of_term t with
     | Rel n  -> PRel n
     | Meta n -> PMeta (Some (Id.of_string ("META" ^ string_of_int n)))
@@ -132,11 +133,11 @@ let pattern_of_constr env sigma t =
     | 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)
+				  pattern_of_constr (push_rel (LocalDef (na,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)
+				pattern_of_constr (push_rel (LocalAssum (na, c)) env) b)
     | Lambda (na,c,b) -> PLambda (na,pattern_of_constr env c,
-				  pattern_of_constr (push_rel (na, None, c) env) b)
+				  pattern_of_constr (push_rel (LocalAssum (na, c)) env) b)
     | App (f,a) ->
         (match
           match kind_of_term f with
@@ -316,6 +317,10 @@ let rev_it_mkPLambda = List.fold_right mkPLambda
 
 let err loc pp = user_err_loc (loc,"pattern_of_glob_constr", pp)
 
+let warn_cast_in_pattern =
+  CWarnings.create ~name:"cast-in-pattern" ~category:"automation"
+    (fun () -> Pp.strbrk "Casts are ignored in patterns")
+
 let rec pat_of_raw metas vars = function
   | GVar (_,id) ->
       (try PRel (List.index Name.equal (Name id) vars)
@@ -347,7 +352,7 @@ let rec pat_of_raw metas vars = function
   | GHole _ ->
       PMeta None
   | GCast (_,c,_) ->
-      Pp.msg_warning (strbrk "Cast not taken into account in constr pattern");
+      warn_cast_in_pattern ();
       pat_of_raw metas vars c
   | GIf (_,c,(_,None),b1,b2) ->
       PIf (pat_of_raw metas vars c,
diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli
index 5f877814..1f63565d 100644
--- a/pretyping/patternops.mli
+++ b/pretyping/patternops.mli
@@ -6,7 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Context
 open Term
 open Globnames
 open Glob_term
diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml
index cf5b08c5..00b6100c 100644
--- a/pretyping/pretype_errors.ml
+++ b/pretyping/pretype_errors.ml
@@ -14,15 +14,16 @@ open Type_errors
 
 type unification_error =
   | OccurCheck of existential_key * constr
-  | NotClean of existential * env * constr
+  | NotClean of existential * env * constr (* Constr is a variable not in scope *)
   | NotSameArgSize
   | NotSameHead
   | NoCanonicalStructure
-  | ConversionFailed of env * constr * constr
+  | ConversionFailed of env * constr * constr (* Non convertible closed terms *)
   | MetaOccurInBody of existential_key
   | InstanceNotSameType of existential_key * env * types * types
   | UnifUnivInconsistency of Univ.univ_inconsistency
   | CannotSolveConstraint of Evd.evar_constraint * unification_error
+  | ProblemBeyondCapabilities
 
 type position = (Id.t * Locus.hyp_location_flag) option
 
@@ -59,7 +60,7 @@ type pretype_error =
 exception PretypeError of env * Evd.evar_map * pretype_error
 
 let precatchable_exception = function
-  | Errors.UserError _ | TypeError _ | PretypeError _
+  | CErrors.UserError _ | TypeError _ | PretypeError _
   | Nametab.GlobalizationError _ -> true
   | _ -> false
 
diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli
index f617df9e..880f48e5 100644
--- a/pretyping/pretype_errors.mli
+++ b/pretyping/pretype_errors.mli
@@ -24,6 +24,7 @@ type unification_error =
   | InstanceNotSameType of existential_key * env * types * types
   | UnifUnivInconsistency of Univ.univ_inconsistency
   | CannotSolveConstraint of Evd.evar_constraint * unification_error
+  | ProblemBeyondCapabilities
 
 type position = (Id.t * Locus.hyp_location_flag) option
 
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index ac0104d9..4b6d10c6 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -22,13 +22,12 @@
 
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Evd
 open Term
 open Vars
-open Context
 open Termops
 open Reductionops
 open Environ
@@ -37,17 +36,20 @@ open Typeops
 open Globnames
 open Nameops
 open Evarutil
+open Evardefine
 open Pretype_errors
 open Glob_term
 open Glob_ops
 open Evarconv
 open Pattern
 open Misctypes
+open Sigma.Notations
+open Context.Named.Declaration
 
 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 unbound_ltac_var_map = Geninterp.Val.t Id.Map.t
 type ltac_var_map = {
   ltac_constrs : var_map;
   ltac_uconstrs : uconstr_var_map;
@@ -56,6 +58,8 @@ type ltac_var_map = {
 }
 type glob_constr_ltac_closure = ltac_var_map * glob_constr
 type pure_open_constr = evar_map * constr
+type 'a delayed_open =
+  { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma }
 
 (************************************************************************)
 (* This concerns Cases *)
@@ -64,6 +68,61 @@ open Inductiveops
 
 (************************************************************************)
 
+module ExtraEnv =
+struct
+
+type t = {
+  env : Environ.env;
+  extra : Evarutil.ext_named_context Lazy.t;
+  (** Delay the computation of the evar extended environment *)
+}
+
+let get_extra env =
+  let open Context.Named.Declaration in
+  let ids = List.map get_id (named_context env) in
+  let avoid = List.fold_right Id.Set.add ids Id.Set.empty in
+  Context.Rel.fold_outside push_rel_decl_to_named_context
+    (Environ.rel_context env) ~init:(empty_csubst, [], avoid, named_context env)
+
+let make_env env = { env = env; extra = lazy (get_extra env) }
+let rel_context env = rel_context env.env
+
+let push_rel d env = {
+  env = push_rel d env.env;
+  extra = lazy (push_rel_decl_to_named_context d (Lazy.force env.extra));
+}
+
+let pop_rel_context n env = make_env (pop_rel_context n env.env)
+
+let push_rel_context ctx env = {
+  env = push_rel_context ctx env.env;
+  extra = lazy (List.fold_right push_rel_decl_to_named_context ctx (Lazy.force env.extra));
+}
+
+let lookup_named id env = lookup_named id env.env
+
+let e_new_evar env evdref ?src ?naming typ =
+  let subst2 subst vsubst c = csubst_subst subst (replace_vars vsubst c) in
+  let open Context.Named.Declaration in
+  let inst_vars = List.map (fun d -> mkVar (get_id d)) (named_context env.env) in
+  let inst_rels = List.rev (rel_list 0 (nb_rel env.env)) in
+  let (subst, vsubst, _, nc) = Lazy.force env.extra in
+  let typ' = subst2 subst vsubst typ in
+  let instance = inst_rels @ inst_vars in
+  let sign = val_of_named_context nc in
+  let sigma = Sigma.Unsafe.of_evar_map !evdref in
+  let Sigma (e, sigma, _) = new_evar_instance sign sigma typ' ?src ?naming instance in
+  evdref := Sigma.to_evar_map sigma;
+  e
+
+let push_rec_types (lna,typarray,_) env =
+  let ctxt = Array.map2_i (fun i na t -> Context.Rel.Declaration.LocalAssum (na, lift i t)) lna typarray in
+  Array.fold_left (fun e assum -> push_rel assum e) env ctxt
+
+end
+
+open ExtraEnv
+
 (* An auxiliary function for searching for fixpoint guard indexes *)
 
 exception Found of int array
@@ -77,7 +136,7 @@ let search_guard loc env possible_indexes fixdefs =
     let fix = ((indexes, 0),fixdefs) in
     (try check_fix env fix
      with reraise ->
-       let (e, info) = Errors.push reraise in
+       let (e, info) = CErrors.push reraise in
        let info = Loc.add_loc info loc in
        iraise (e, info));
     indexes
@@ -87,18 +146,23 @@ let search_guard loc env possible_indexes fixdefs =
        List.iter
 	 (fun l ->
 	    let indexes = Array.of_list l in
-	    let fix = ((indexes, 0),fixdefs) in
-	    try check_fix env fix; raise (Found indexes)
+            let fix = ((indexes, 0),fixdefs) in
+            (* spiwack: We search for a unspecified structural
+               argument under the assumption that we need to check the
+               guardedness condition (otherwise the first inductive argument
+               will be chosen). A more robust solution may be to raise an
+               error when totality is assumed but the strutural argument is
+               not specified. *)
+            try
+              let flags = { (typing_flags env) with Declarations.check_guarded = true } in
+              let env = Environ.set_typing_flags flags env in
+              check_fix env fix; raise (Found indexes)
 	    with TypeError _ -> ())
 	 (List.combinations possible_indexes);
        let errmsg = "Cannot guess decreasing argument of fix." in
 	 user_err_loc (loc,"search_guard", Pp.str errmsg)
      with Found indexes -> indexes)
 
-(* To embed constr in glob_constr *)
-let ((constr_in : constr -> Dyn.t),
-     (constr_out : Dyn.t -> constr)) = Dyn.create "constr"
-
 (* To force universe name declaration before use *)
 
 let strict_universe_declarations = ref true
@@ -134,24 +198,24 @@ let interp_universe_level_name evd (loc,s) =
 	 let level = Univ.Level.make dp num in
 	 let evd =
 	   try Evd.add_global_univ evd level
-	   with Univ.AlreadyDeclared -> evd
+	   with UGraph.AlreadyDeclared -> evd
 	 in evd, level
     else 
       try
-	let id =
-	  try Id.of_string s with _ -> raise Not_found in
-	  evd, Idmap.find id names
+	let level = Evd.universe_of_name evd s in
+	evd, level
       with Not_found ->
-	try let level = Evd.universe_of_name evd s in
-	      evd, level
+	try 
+	  let id = try Id.of_string s with _ -> raise Not_found in
+          evd, snd (Idmap.find id names)
 	with Not_found -> 
 	  if not (is_strict_universe_declarations ()) then
-  	    new_univ_level_variable ~name:s univ_rigid evd
+  	    new_univ_level_variable ~loc ~name:s univ_rigid evd
 	  else user_err_loc (loc, "interp_universe_level_name",
 			     Pp.(str "Undeclared universe: " ++ str s))
 
-let interp_universe evd = function
-  | [] -> let evd, l = new_univ_level_variable univ_rigid evd in
+let interp_universe ?loc evd = function
+  | [] -> let evd, l = new_univ_level_variable ?loc univ_rigid evd in
 	    evd, Univ.Universe.make l
   | l ->
     List.fold_left (fun (evd, u) l -> 
@@ -159,15 +223,15 @@ let interp_universe evd = function
 	(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
+let interp_universe_level loc evd = function
+  | None -> new_univ_level_variable ~loc univ_rigid evd
   | Some (loc,s) -> interp_universe_level_name evd (loc,s)
 
-let interp_sort evd = function
+let interp_sort ?loc evd = function
   | GProp -> evd, Prop Null
   | GSet -> evd, Prop Pos
   | GType n -> 
-    let evd, u = interp_universe evd n in
+    let evd, u = interp_universe ?loc evd n in
       evd, Type u
 
 let interp_elimination_sort = function
@@ -175,23 +239,31 @@ let interp_elimination_sort = function
   | GSet  -> InSet
   | GType _ -> InType
 
+type inference_hook = env -> evar_map -> evar -> evar_map * constr
+
 type inference_flags = {
   use_typeclasses : bool;
-  use_unif_heuristics : bool;
-  use_hook : (env -> evar_map -> evar -> constr) option;
+  solve_unification_constraints : bool;
+  use_hook : inference_hook option;
   fail_evar : bool;
   expand_evars : bool
 }
 
-let frozen_holes (sigma, sigma') =
-  let fold evk _ accu = Evar.Set.add evk accu in
-  Evd.fold_undefined fold sigma Evar.Set.empty
-
-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
+(* Compute the set of still-undefined initial evars up to restriction
+   (e.g. clearing) and the set of yet-unsolved evars freshly created
+   in the extension [sigma'] of [sigma] (excluding the restrictions of
+   the undefined evars of [sigma] to be freshly created evars of
+   [sigma']). Otherwise said, we partition the undefined evars of
+   [sigma'] into those already in [sigma] or deriving from an evar in
+   [sigma] by restriction, and the evars properly created in [sigma'] *)
+
+let frozen_and_pending_holes (sigma, sigma') =
+  let add_derivative_of evk evi acc =
+    match advance sigma' evk with None -> acc | Some evk' -> Evar.Set.add evk' acc in
+  let frozen = Evd.fold_undefined add_derivative_of sigma Evar.Set.empty in
+  let fold evk _ accu = if not (Evar.Set.mem evk frozen) then Evar.Set.add evk accu else accu in
+  let pending = Evd.fold_undefined fold sigma' Evar.Set.empty in
+  (frozen,pending)
 
 let apply_typeclasses env evdref frozen fail_evar =
   let filter_frozen evk = Evar.Set.mem evk frozen in
@@ -209,7 +281,7 @@ let apply_inference_hook hook evdref pending =
     if Evd.is_undefined sigma evk (* in particular not defined by side-effect *)
     then
       try
-        let c = hook sigma evk in
+        let sigma, c = hook sigma evk in
         Evd.define evk c sigma
       with Exit ->
         sigma
@@ -218,10 +290,10 @@ let apply_inference_hook hook evdref pending =
 
 let apply_heuristics env evdref fail_evar =
   (* Resolve eagerly, potentially making wrong choices *)
-  try evdref := consider_remaining_unif_problems
+  try evdref := solve_unif_constraints_with_heuristics
 	~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
+  with e when CErrors.noncritical e ->
+    let e = CErrors.push e in if fail_evar then iraise e
 
 let check_typeclasses_instances_are_solved env current_sigma frozen =
   (* Naive way, call resolution again with failure flag *)
@@ -237,6 +309,23 @@ let check_extra_evars_are_solved env current_sigma pending =
 	| _ ->
 	    error_unsolvable_implicit loc env current_sigma evk None) pending
 
+(* [check_evars] fails if some unresolved evar remains *)
+
+let check_evars env initial_sigma sigma c =
+  let rec proc_rec c =
+    match kind_of_term c with
+    | Evar (evk,_ as ev) ->
+        (match existential_opt_value sigma ev with
+        | Some c -> proc_rec c
+        | None ->
+	  if not (Evd.mem initial_sigma evk) then
+            let (loc,k) = evar_source evk sigma in
+	      match k with
+	      | Evar_kinds.ImplicitArg (gr, (i, id), false) -> ()
+	      | _ -> Pretype_errors.error_unsolvable_implicit loc env sigma evk None)
+      | _ -> Constr.iter proc_rec c
+  in proc_rec c
+
 let check_evars_are_solved env current_sigma frozen pending =
   check_typeclasses_instances_are_solved env current_sigma frozen;
   check_problems_are_solved env current_sigma;
@@ -245,19 +334,17 @@ let check_evars_are_solved env current_sigma frozen pending =
 (* Try typeclasses, hooks, unification heuristics ... *)
 
 let solve_remaining_evars flags env current_sigma pending =
-  let frozen = frozen_holes pending in
-  let pending = pending_holes pending in
+  let frozen,pending = frozen_and_pending_holes pending in
   let evdref = ref current_sigma in
   if flags.use_typeclasses then apply_typeclasses env evdref frozen 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.solve_unification_constraints then apply_heuristics env evdref false;
   if flags.fail_evar then check_evars_are_solved env !evdref frozen pending;
   !evdref
 
 let check_evars_are_solved env current_sigma pending =
-  let frozen = frozen_holes pending in
-  let pending = pending_holes pending in
+  let frozen,pending = frozen_and_pending_holes pending in
   check_evars_are_solved env current_sigma frozen pending
 
 let process_inference_flags flags env initial_sigma (sigma,c) =
@@ -268,26 +355,11 @@ let process_inference_flags flags env initial_sigma (sigma,c) =
 (* Allow references to syntactically nonexistent 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
+      evd_comb2 (Coercion.inh_conv_coerce_to resolve_tc loc env.ExtraEnv.env) evdref j t
 
 let check_instance loc subst = function
   | [] -> ()
@@ -321,11 +393,12 @@ let ltac_interp_name_env k0 lvar env =
      specification of pretype which accepts to start with a non empty
      rel_context) *)
   (* tail is the part of the env enriched by pretyping *)
-  let n = rel_context_length (rel_context env) - k0 in
+  let n = Context.Rel.length (rel_context env) - k0 in
   let ctxt,_ = List.chop n (rel_context env) in
-  let env = pop_rel_context n env in
-  let ctxt = List.map (fun (na,c,t) -> ltac_interp_name lvar na,c,t) ctxt in
-  push_rel_context ctxt env
+  let open Context.Rel.Declaration in
+  let ctxt' = List.smartmap (map_name (ltac_interp_name lvar)) ctxt in
+  if List.equal (fun d1 d2 -> Name.equal (get_name d1) (get_name d2)) ctxt ctxt' then env
+  else push_rel_context ctxt' (pop_rel_context n env)
 
 let invert_ltac_bound_name lvar env id0 id =
   let id' = Id.Map.find id lvar.ltac_idents in
@@ -336,7 +409,7 @@ let invert_ltac_bound_name lvar env id0 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
+  try Retyping.get_type_of ~lax:true env.ExtraEnv.env sigma c
   with Retyping.RetypeError _ ->
     errorlabstrm ""
       (str "Cannot reinterpret " ++ quote (print_constr c) ++
@@ -372,13 +445,15 @@ let pretype_id pretype k0 loc env evdref lvar id =
     with Not_found ->
         (* 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
+      if Id.Map.mem id lvar.ltac_genargs then begin
+        let Geninterp.Val.Dyn (typ, _) = Id.Map.find id lvar.ltac_genargs in
 	user_err_loc (loc,"",
-          str "Variable " ++ pr_id id ++ str " should be bound to a term.");
+          str "Variable " ++ pr_id id ++ str " should be bound to a term but is \
+          bound to a " ++ Geninterp.Val.pr typ ++ str ".")
+      end;
       (* Check if [id] is a section or goal variable *)
       try
-	let (_,_,typ) = lookup_named id env in
-	  { uj_val  = mkVar id; uj_type = typ }
+	  { uj_val  = mkVar id; uj_type = (get_type (lookup_named id env)) }
       with Not_found ->
 	  (* [id] not found, standard error message *)
 	  error_var_not_found_loc loc id
@@ -389,11 +464,11 @@ let evar_kind_of_term sigma c =
 (*************************************************************************)
 (* Main pretyping function                                               *)
 
-let interp_universe_level_name evd l =
+let interp_universe_level_name loc evd l =
   match l with
   | GProp -> evd, Univ.Level.prop
   | GSet -> evd, Univ.Level.set
-  | GType s -> interp_universe_level evd s
+  | GType s -> interp_universe_level loc evd s
 
 let pretype_global loc rigid env evd gr us = 
   let evd, instance = 
@@ -408,7 +483,7 @@ let pretype_global loc rigid env evd gr us =
 		       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
+	    let evd, l = interp_universe_level_name loc evd l in
 	      (evd, l :: univs)) (evd, []) l
 	 in
 	 if List.exists (fun l -> Univ.Level.is_prop l) l' then
@@ -417,14 +492,13 @@ let pretype_global loc rigid env evd gr us =
 		   str " universe instances must be greater or equal to Set.");
 	 evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l')))
   in
-    Evd.fresh_global ~rigid ?names:instance env evd gr
+    Evd.fresh_global ~loc ~rigid ?names:instance env.ExtraEnv.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
+      (try make_judge (mkVar id) (get_type (lookup_named id env))
        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
@@ -433,34 +507,29 @@ let pretype_ref loc evdref env ref us =
   | ref ->
     let evd, c = pretype_global loc univ_flexible env !evdref ref us in
     let () = evdref := evd in
-    let ty = Typing.unsafe_type_of env evd c in
+    let ty = Typing.unsafe_type_of env.ExtraEnv.env evd c in
       make_judge c ty
 
-let judge_of_Type evd s =
-  let evd, s = interp_universe evd s in
+let judge_of_Type loc evd s =
+  let evd, s = interp_universe ~loc 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
+let pretype_sort loc evdref = function
   | GProp -> judge_of_prop
   | GSet -> judge_of_set
-  | GType s -> evd_comb1 judge_of_Type evdref s
+  | GType s -> evd_comb1 (judge_of_Type loc) 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 sigma = Sigma.Unsafe.of_evar_map !evdref in
+  let Sigma ((e, _), sigma, _) =
+    Evarutil.new_type_evar env.ExtraEnv.env sigma
+      univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)
+  in
+  evdref := Sigma.to_evar_map sigma;
+  e
 
 let (f_genarg_interp, genarg_interp_hook) = Hook.make ()
 
@@ -468,16 +537,11 @@ let (f_genarg_interp, genarg_interp_hook) = Hook.make ()
 (* 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 k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var_map) t =
+let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) 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 k0 resolve_tc in
   let pretype = pretype k0 resolve_tc in
+  let open Context.Rel.Declaration in
   match t with
   | GRef (loc,ref,u) ->
       inh_conv_coerce_to_tycon loc env evdref
@@ -499,7 +563,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
       let hyps = evar_filtered_context (Evd.find !evdref evk) in
       let args = pretype_instance k0 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
+      let j = (Retyping.get_judgment_of env.ExtraEnv.env !evdref c) in
 	inh_conv_coerce_to_tycon loc env evdref j tycon
 
   | GPatVar (loc,(someta,n)) ->
@@ -528,7 +592,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
         | 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 (c, sigma) = Hook.get f_genarg_interp ty env.ExtraEnv.env !evdref ist arg in
       let () = evdref := sigma in
       { uj_val = c; uj_type = ty }
 
@@ -537,16 +601,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
     [] -> 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
-        let dcl' = (ltac_interp_name lvar na,None,ty'.utj_val) in
-	  type_bl (push_rel dcl env) (add_rel_decl dcl' ctxt) bl
+	let dcl = LocalAssum (na, ty'.utj_val) in
+        let dcl' = LocalAssum (ltac_interp_name lvar na,ty'.utj_val) in
+	  type_bl (push_rel dcl env) (Context.Rel.add 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
-        let dcl' = (ltac_interp_name lvar 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 dcl = LocalDef (na, bd'.uj_val, ty'.utj_val) in
+        let dcl' = LocalDef (ltac_interp_name lvar na, bd'.uj_val, ty'.utj_val) in
+	  type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl in
+    let ctxtv = Array.map (type_bl env Context.Rel.empty) bl in
     let larj =
       Array.map2
         (fun e ar ->
@@ -562,7 +626,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
  	let fixi = match fixkind with
 	  | GFix (vn,i) -> i
 	  | GCoFix i -> i
-	in e_conv env evdref ftys.(fixi) t
+	in e_conv env.ExtraEnv.env evdref ftys.(fixi) t
       | None -> true
     in
       (* Note: bodies are not used by push_rec_types, so [||] is safe *)
@@ -573,14 +637,14 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
              (* 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)
+	    decompose_prod_n_assum (Context.Rel.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;
+      Typing.check_type_fixpoint loc env.ExtraEnv.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
@@ -599,13 +663,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
 			     vn)
 	  in
 	  let fixdecls = (names,ftys,fdefs) in
-	  let indexes = search_guard loc env possible_indexes fixdecls in
+          let indexes =
+            search_guard
+              loc env.ExtraEnv.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
+            (try check_cofix env.ExtraEnv.env cofix
              with reraise ->
-               let (e, info) = Errors.push reraise in
+               let (e, info) = CErrors.push reraise in
                let info = Loc.add_loc info loc in
                iraise (e, info));
 	    make_judge (mkCoFix cofix) ftys.(i)
@@ -613,7 +680,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
 	inh_conv_coerce_to_tycon loc env evdref fixj tycon
 
   | GSort (loc,s) ->
-    let j = pretype_sort evdref s in
+    let j = pretype_sort loc evdref s in
       inh_conv_coerce_to_tycon loc env evdref j tycon
 
   | GApp (loc,f,args) ->
@@ -633,7 +700,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
 	    if Int.equal npars 0 then []
 	    else
 	      try
-	  	let IndType (indf, args) = find_rectype env !evdref ty in
+	  	let IndType (indf, args) = find_rectype env.ExtraEnv.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 *) []
@@ -642,9 +709,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
     in
     let app_f = 
       match kind_of_term fj.uj_val with
-      | Const (p, u) when Environ.is_projection p env ->
+      | Const (p, u) when Environ.is_projection p env.ExtraEnv.env ->
 	let p = Projection.make p false in
-	let pb = Environ.lookup_projection p env in
+	let pb = Environ.lookup_projection p env.ExtraEnv.env in
 	let npars = pb.Declarations.proj_npars in
 	  fun n -> 
 	    if n == npars + 1 then fun _ v -> mkProj (p, v)
@@ -655,8 +722,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
       | [] -> 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
+	let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env.ExtraEnv.env) evdref resj in
+        let resty = whd_all env.ExtraEnv.env !evdref resj.uj_type in
       	  match kind_of_term resty with
 	  | Prod (na,c1,c2) ->
 	    let tycon = Some c1 in
@@ -665,7 +732,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
 	      match candargs with
 	      | [] -> [], j_val hj
 	      | arg :: args -> 
-		if e_conv env evdref (j_val hj) arg then
+		if e_conv env.ExtraEnv.env evdref (j_val hj) arg then
 		  args, nf_evar !evdref (j_val hj)
 		else [], j_val hj
 	    in
@@ -676,7 +743,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
 	  | _ ->
 	    let hj = pretype empty_tycon env evdref lvar c in
 	      error_cant_apply_not_functional_loc
-		(Loc.merge floc argloc) env !evdref
+		(Loc.merge floc argloc) env.ExtraEnv.env !evdref
 	      	resj [hj]
     in
     let resj = apply_rec env 1 fj candargs args in
@@ -684,13 +751,13 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
       match evar_kind_of_term !evdref resj.uj_val with
       | App (f,args) ->
         let f = whd_evar !evdref f in
-          if is_template_polymorphic env f then
+          if is_template_polymorphic env.ExtraEnv.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
+	    let c = evd_comb1 (Evarsolve.refresh_universes (Some true) env.ExtraEnv.env) evdref c in
+	    let t = Retyping.get_type_of env.ExtraEnv.env !evdref c in
 	      make_judge c (* use this for keeping evars: resj.uj_val *) t
 	  else resj
       | _ -> resj 
@@ -703,20 +770,20 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
 	match tycon with
 	| None -> evd, tycon
 	| Some ty ->
-	  let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in
+	  let evd, ty' = Coercion.inh_coerce_to_prod loc env.ExtraEnv.env evd ty in
 	    evd, Some ty')
       evdref tycon
     in
-    let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in
+    let (name',dom,rng) = evd_comb1 (split_tycon loc env.ExtraEnv.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 var = (name,None,j.utj_val) in
+    let var = LocalAssum (name, j.utj_val) in
     let j' = pretype rng (push_rel var env) evdref lvar c2 in
     let name = ltac_interp_name lvar name in
-    let resj = judge_of_abstraction env (orelse_name name name') j j' in
+    let resj = judge_of_abstraction env.ExtraEnv.env (orelse_name name name') j j' in
       inh_conv_coerce_to_tycon loc env evdref resj tycon
 
   | GProd(loc,name,bk,c1,c2)        ->
@@ -729,16 +796,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
         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
+        let var = LocalAssum (name, j.utj_val) in
+        let env' = push_rel var env in
           pretype_type empty_valcon env' evdref lvar c2
     in
     let name = ltac_interp_name lvar name in
     let resj =
       try
-        judge_of_product env name j j'
+        judge_of_product env.ExtraEnv.env name j j'
       with TypeError _ as e ->
-        let (e, info) = Errors.push e in
+        let (e, info) = CErrors.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
@@ -752,12 +819,12 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
       | _ -> pretype empty_tycon env evdref lvar c1
     in
     let t = evd_comb1 (Evarsolve.refresh_universes
-      ~onlyalg:true ~status:Evd.univ_flexible (Some false) env)
+      ~onlyalg:true ~status:Evd.univ_flexible (Some false) env.ExtraEnv.env)
       evdref 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 var = (name,Some j.uj_val,t) in
+    let var = LocalDef (name, j.uj_val, t) in
     let tycon = lift_tycon 1 tycon in
     let j' = pretype tycon (push_rel var env) evdref lvar c2 in
     let name = ltac_interp_name lvar name in
@@ -767,12 +834,12 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
   | 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
+      try find_rectype env.ExtraEnv.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
+	  error_case_not_inductive_loc cloc env.ExtraEnv.env !evdref cj
     in
-    let cstrs = get_constructors env indf in
+    let cstrs = get_constructors env.ExtraEnv.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.");
@@ -781,18 +848,18 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
       user_err_loc (loc,"", str "Destructing let on this type expects " ++ 
 	int cs.cs_nargs ++ str " variables.");
     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
+      match get_projections env.ExtraEnv.env indf with
+      | None ->
+	 List.map2 set_name (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) -> 
+	  | na :: names, (LocalAssum (_,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)
+	    LocalDef (na, 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
+	  | na :: names, (decl :: l) ->
+	    set_name na decl :: aux (n+1) k names l
 	  | [], [] -> []
 	  | _ -> assert false
 	in aux 1 1 (List.rev nal) cs.cs_args, true in
@@ -800,38 +867,38 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
       if not record then 
         let nal = List.map (fun na -> ltac_interp_name lvar na) nal in
         let nal = List.rev nal in
-        let fsign = List.map2 (fun na (_,b,t) -> (na,b,t)) nal fsign in
+        let fsign = List.map2 set_name nal fsign in
 	let f = it_mkLambda_or_LetIn f fsign in
-	let ci = make_case_info env (fst ind) LetStyle in
+	let ci = make_case_info env.ExtraEnv.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
+      let arsgn,_ = get_arity env.ExtraEnv.env indf in
 	if not !allow_anonymous_refs then
-	  List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
+	  List.map (set_name Anonymous) arsgn
 	else arsgn
     in
-      let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+      let psign = LocalAssum (na, build_dependent_inductive env.ExtraEnv.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 psign = make_arity_signature env.ExtraEnv.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 fty = hnf_lam_applist env.ExtraEnv.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;
+		Typing.check_allowed_sort env.ExtraEnv.env !evdref ind cj.uj_val p;
 		obj ind p cj.uj_val fj.uj_val
 	    in
 	      { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
@@ -844,37 +911,37 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
 	      if noccur_between 1 cs.cs_nargs ccl then
 		lift (- cs.cs_nargs) ccl
 	      else
-		error_cant_find_case_type_loc loc env !evdref
+		error_cant_find_case_type_loc loc env.ExtraEnv.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;
+		Typing.check_allowed_sort env.ExtraEnv.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
+      try find_rectype env.ExtraEnv.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
+	  error_case_not_inductive_loc cloc env.ExtraEnv.env !evdref cj in
+    let cstrs = get_constructors env.ExtraEnv.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
+	let arsgn,_ = get_arity env.ExtraEnv.env indf in
 	  if not !allow_anonymous_refs then
 	      (* Make dependencies from arity signature impossible *)
-	    List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
+	    List.map (set_name Anonymous) arsgn
 	  else arsgn
       in
       let nar = List.length arsgn in
-      let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+      let psign = LocalAssum (na, build_dependent_inductive env.ExtraEnv.env indf) :: arsgn in
       let pred,p = match po with
 	| Some p ->
 	  let env_p = push_rel_context psign env in
@@ -894,19 +961,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
       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 n = Context.Rel.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
+	    List.map (set_name Anonymous) 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
+	    List.map (map_name (function Name _ as n -> n
+				       | Anonymous -> Name Namegen.default_non_dependent_ident))
+		     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
@@ -915,9 +979,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
       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 ci = make_case_info env.ExtraEnv.env (fst ind) IfStyle in
 	let pred = nf_evar !evdref pred in
-	  Typing.check_allowed_sort env !evdref ind cj.uj_val pred;
+	  Typing.check_allowed_sort env.ExtraEnv.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
@@ -925,51 +989,55 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
 
   | 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)
+      ((fun vtyc env evdref -> pretype vtyc (make_env env) evdref lvar),evdref)
+      tycon env.ExtraEnv.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
+	  evd_comb1 (Coercion.inh_coerce_to_base loc env.ExtraEnv.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
+        let tval = evd_comb1 (Evarsolve.refresh_universes
+                             ~onlyalg:true ~status:Evd.univ_flexible (Some false) env.ExtraEnv.env)
+                          evdref tj.utj_val in
+	let tval = nf_evar !evdref tval in
+	let cj, tval = 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
+	    let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in
 	      if not (occur_existential cty || occur_existential tval) then
-		let (evd,b) = Reductionops.vm_infer_conv env !evdref cty tval in
-		if b then (evdref := evd; cj)
+		let (evd,b) = Reductionops.vm_infer_conv env.ExtraEnv.env !evdref cty tval in
+		if b then (evdref := evd; cj, tval)
 		else
-		  error_actual_type_loc loc env !evdref cj tval 
-                      (ConversionFailed (env,cty,tval))
+		  error_actual_type_loc loc env.ExtraEnv.env !evdref cj tval 
+                      (ConversionFailed (env.ExtraEnv.env,cty,tval))
 	      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 cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in
             begin
-	      let (evd,b) = Nativenorm.native_infer_conv env !evdref cty tval in
-	      if b then (evdref := evd; cj)
+	      let (evd,b) = Nativenorm.native_infer_conv env.ExtraEnv.env !evdref cty tval in
+	      if b then (evdref := evd; cj, tval)
 	      else
-                error_actual_type_loc loc env !evdref cj tval 
-                  (ConversionFailed (env,cty,tval))
+                error_actual_type_loc loc env.ExtraEnv.env !evdref cj tval 
+                  (ConversionFailed (env.ExtraEnv.env,cty,tval))
             end
 	  | _ -> 
- 	    pretype (mk_tycon tval) env evdref lvar c
+ 	    pretype (mk_tycon tval) env evdref lvar c, 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
 
 and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update =
-  let f (id,_,t) (subst,update) =
-    let t = replace_vars subst t in
+  let f decl (subst,update) =
+    let id = get_id decl in
+    let t = replace_vars subst (get_type decl) in
     let c, update =
       try
         let c = List.assoc id update in
@@ -978,11 +1046,11 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk 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
+        if is_conv env.ExtraEnv.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
+        let t' = lookup_named id env |> get_type in
+        if is_conv env.ExtraEnv.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 ++
@@ -993,17 +1061,17 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update =
   Array.map_of_list snd subst
 
 (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *)
-and pretype_type k0 resolve_tc valcon env evdref lvar = function
+and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) 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
+	     let t = Retyping.get_type_of env.ExtraEnv.env sigma v in
+	       match kind_of_term (whd_all env.ExtraEnv.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
+		   evd_comb1 (define_evar_as_sort env.ExtraEnv.env) evdref ev
                | _ -> anomaly (Pp.str "Found a type constraint which is not a type")
            in
 	     { utj_val = v;
@@ -1016,18 +1084,19 @@ and pretype_type k0 resolve_tc valcon env evdref lvar = function
   | c ->
       let j = pretype k0 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
+      let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env.ExtraEnv.env) evdref j in
 	match valcon with
 	| None -> tj
 	| Some v ->
-	    if e_cumul env evdref v tj.utj_val then tj
+	    if e_cumul env.ExtraEnv.env evdref v tj.utj_val then tj
 	    else
 	      error_unexpected_type_loc
-                (loc_of_glob_constr c) env !evdref tj.utj_val v
+                (loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val v
 
 let ise_pretype_gen flags env sigma lvar kind c =
+  let env = make_env env in
   let evdref = ref sigma in
-  let k0 = rel_context_length (rel_context env) in
+  let k0 = Context.Rel.length (rel_context env) in
   let c' = match kind with
     | WithoutTypeConstraint ->
         (pretype k0 flags.use_typeclasses empty_tycon env evdref lvar c).uj_val
@@ -1036,18 +1105,18 @@ let ise_pretype_gen flags env sigma lvar kind c =
     | IsType ->
 	(pretype_type k0 flags.use_typeclasses empty_valcon env evdref lvar c).utj_val 
   in
-  process_inference_flags flags env sigma (!evdref,c')
+  process_inference_flags flags env.ExtraEnv.env sigma (!evdref,c')
 
 let default_inference_flags fail = {
   use_typeclasses = true;
-  use_unif_heuristics = true;
+  solve_unification_constraints = true;
   use_hook = None;
   fail_evar = fail;
   expand_evars = true }
 
 let no_classes_no_fail_inference_flags = {
   use_typeclasses = false;
-  use_unif_heuristics = true;
+  solve_unification_constraints = true;
   use_hook = None;
   fail_evar = false;
   expand_evars = true }
@@ -1068,19 +1137,21 @@ let on_judgment f j =
   {uj_val = c; uj_type = t}
 
 let understand_judgment env sigma c =
+  let env = make_env env in
   let evdref = ref sigma in
-  let k0 = rel_context_length (rel_context env) in
+  let k0 = Context.Rel.length (rel_context env) in
   let j = pretype k0 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 
+    let evd, c = process_inference_flags all_and_fail_flags env.ExtraEnv.env sigma (!evdref,c) in 
       evdref := evd; c) j
   in j, Evd.evar_universe_context !evdref
 
 let understand_judgment_tcc env evdref c =
-  let k0 = rel_context_length (rel_context env) in
+  let env = make_env env in
+  let k0 = Context.Rel.length (rel_context env) in
   let j = pretype k0 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
+    let (evd,c) = process_inference_flags all_no_fail_flags env.ExtraEnv.env Evd.empty (!evdref,c) in
     evdref := evd; c) j
 
 let ise_pretype_gen_ctx flags env sigma lvar kind c =
@@ -1106,3 +1177,32 @@ let understand_tcc_evars ?(flags=all_no_fail_flags) env evdref ?(expected_type=W
 
 let understand_ltac flags env sigma lvar kind c =
   ise_pretype_gen flags env sigma lvar kind c
+
+let constr_flags = {
+  use_typeclasses = true;
+  solve_unification_constraints = true;
+  use_hook = None;
+  fail_evar = true;
+  expand_evars = true }
+
+(* Fully evaluate an untyped constr *)
+let type_uconstr ?(flags = constr_flags)
+  ?(expected_type = WithoutTypeConstraint) ist c =
+  { delayed = begin fun env sigma ->
+  let { closure; term } = c in
+  let vars = {
+    ltac_constrs = closure.typed;
+    ltac_uconstrs = closure.untyped;
+    ltac_idents = closure.idents;
+    ltac_genargs = Id.Map.empty;
+  } in
+  let sigma = Sigma.to_evar_map sigma in
+  let (sigma, c) = understand_ltac flags env sigma vars expected_type term in
+  Sigma.Unsafe.of_pair (c, sigma)
+  end }
+
+let pretype k0 resolve_tc typcon env evdref lvar t =
+  pretype k0 resolve_tc typcon (make_env env) evdref lvar t
+
+let pretype_type k0 resolve_tc valcon env evdref lvar t =
+  pretype_type k0 resolve_tc valcon (make_env env) evdref lvar t
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index ac899a78..0f3f7c3c 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -29,7 +29,7 @@ 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 unbound_ltac_var_map = Geninterp.Val.t Id.Map.t
 
 type ltac_var_map = {
   ltac_constrs : var_map;
@@ -47,14 +47,19 @@ val empty_lvar : ltac_var_map
 type glob_constr_ltac_closure = ltac_var_map * glob_constr
 type pure_open_constr = evar_map * constr
 
+type inference_hook = env -> evar_map -> evar -> evar_map * constr
+
 type inference_flags = {
   use_typeclasses : bool;
-  use_unif_heuristics : bool;
-  use_hook : (env -> evar_map -> evar -> constr) option;
+  solve_unification_constraints : bool;
+  use_hook : inference_hook option;
   fail_evar : bool;
   expand_evars : bool
 }
 
+type 'a delayed_open =
+  { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma }
+
 val default_inference_flags : bool -> inference_flags
 
 val no_classes_no_fail_inference_flags : inference_flags
@@ -114,6 +119,11 @@ val understand_judgment : env -> evar_map ->
 val understand_judgment_tcc : env -> evar_map ref ->
   glob_constr -> unsafe_judgment
 
+val type_uconstr :
+  ?flags:inference_flags ->
+  ?expected_type:typing_constraint ->
+  Geninterp.interp_sign -> Glob_term.closed_glob_constr -> constr delayed_open
+
 (** Trying to solve remaining evars and remaining conversion problems
     possibly using type classes, heuristics, external tactic solver
     hook depending on given flags. *)
@@ -130,6 +140,10 @@ val solve_remaining_evars : inference_flags ->
 val check_evars_are_solved :
   env -> (* current map: *) evar_map -> (* map to check: *) pending -> unit
 
+(** [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
+
 (**/**)
 (** Internal of Pretyping... *)
 val pretype :
@@ -148,12 +162,9 @@ val ise_pretype_gen :
 
 (** To embed constr in glob_constr *)
 
-val constr_in : constr -> Dyn.t
-val constr_out : Dyn.t -> constr
-
-val interp_sort : evar_map -> glob_sort -> evar_map * sorts
+val interp_sort : ?loc:Loc.t -> evar_map -> glob_sort -> evar_map * sorts
 val interp_elimination_sort : glob_sort -> sorts_family
 
 val genarg_interp_hook :
-  (types -> env -> evar_map -> Genarg.typed_generic_argument Id.Map.t ->
+  (types -> env -> evar_map -> unbound_ltac_var_map ->
     Genarg.glob_generic_argument -> constr * evar_map) Hook.t
diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib
index a644e3d1..c8b3307d 100644
--- a/pretyping/pretyping.mllib
+++ b/pretyping/pretyping.mllib
@@ -1,7 +1,5 @@
 Locusops
-Termops
-Namegen
-Evd
+Pretype_errors
 Reductionops
 Inductiveops
 Vnorm
@@ -9,9 +7,8 @@ Arguments_renaming
 Nativenorm
 Retyping
 Cbv
-Pretype_errors
 Find_subterm
-Evarutil
+Evardefine
 Evarsolve
 Recordops
 Evarconv
diff --git a/pretyping/program.ml b/pretyping/program.ml
index 0bd121f6..62aedcfb 100644
--- a/pretyping/program.ml
+++ b/pretyping/program.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Term
@@ -15,10 +15,12 @@ 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
+  let dp = make_dir dir in
+  let sp = Libnames.make_path dp (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)
+    user_err_loc (Loc.ghost, "", str "Library " ++ Libnames.pr_dirpath dp ++
+      str " has to be required first.")
 
 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)
@@ -67,3 +69,43 @@ let mk_coq_and l =
       (fun c conj ->
 	 mkApp (and_typ, [| c ; conj |]))
       l
+
+(* true = transparent by default, false = opaque if possible *)
+let proofs_transparency = ref true
+let program_cases = ref true
+let program_generalized_coercion = ref true
+
+let set_proofs_transparency = (:=) proofs_transparency
+let get_proofs_transparency () = !proofs_transparency
+
+let is_program_generalized_coercion () = !program_generalized_coercion
+let is_program_cases () = !program_cases
+
+open Goptions
+
+let _ =
+  declare_bool_option
+  { optsync  = true;
+    optdepr  = false;
+    optname  = "preferred transparency of Program obligations";
+    optkey   = ["Transparent";"Obligations"];
+    optread  = get_proofs_transparency;
+    optwrite = set_proofs_transparency; }
+
+let _ =
+  declare_bool_option
+  { optsync  = true;
+    optdepr  = false;
+    optname  = "program cases";
+    optkey   = ["Program";"Cases"];
+    optread  = (fun () -> !program_cases);
+    optwrite = (:=) program_cases }
+
+let _ =
+  declare_bool_option
+  { optsync  = true;
+    optdepr  = false;
+    optname  = "program generalized coercion";
+    optkey   = ["Program";"Generalized";"Coercion"];
+    optread  = (fun () -> !program_generalized_coercion);
+    optwrite = (:=) program_generalized_coercion }
diff --git a/pretyping/program.mli b/pretyping/program.mli
index b7ebcbc9..023ff8ca 100644
--- a/pretyping/program.mli
+++ b/pretyping/program.mli
@@ -37,3 +37,7 @@ val mk_coq_not : constr -> constr
 
 (** Polymorphic application of delayed references *)
 val papp : Evd.evar_map ref -> (unit -> global_reference) -> constr array -> constr
+
+val get_proofs_transparency : unit -> bool
+val is_program_cases : unit -> bool
+val is_program_generalized_coercion : unit -> bool
diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml
index 560beb6f..284af0cb 100644
--- a/pretyping/recordops.ml
+++ b/pretyping/recordops.ml
@@ -13,7 +13,7 @@
 (* This file registers properties of records: projections and
    canonical structures *)
 
-open Errors
+open CErrors
 open Util
 open Pp
 open Names
@@ -176,7 +176,7 @@ let cs_pattern_of_constr t =
       App (f,vargs) ->
 	begin
 	  try Const_cs (global_of_constr f) , None, Array.to_list vargs
-          with e when Errors.noncritical e -> raise Not_found
+          with e when CErrors.noncritical e -> raise Not_found
 	end
     | Rel n -> Default_cs, Some n, []
     | Prod (_,a,b) when not (Termops.dependent (mkRel 1) b) -> Prod_cs, None, [a; Termops.pop b]
@@ -184,11 +184,18 @@ let cs_pattern_of_constr t =
     | _ ->
 	begin
 	  try Const_cs (global_of_constr t) , None, []
-          with e when Errors.noncritical e -> raise Not_found
+          with e when CErrors.noncritical e -> raise Not_found
 	end
 
+let warn_projection_no_head_constant =
+  CWarnings.create ~name:"projection-no-head-constant" ~category:"typechecker"
+         (fun (t,con_pp,proji_sp_pp) ->
+          strbrk "Projection value has no head constant: "
+          ++ Termops.print_constr t ++ strbrk " in canonical instance "  
+          ++ con_pp ++ str " of " ++ proji_sp_pp ++ strbrk ", ignoring it.")
+
 (* Intended to always succeed *)
-let compute_canonical_projections (con,ind) =
+let compute_canonical_projections warn (con,ind) =
   let env = Global.env () in
   let ctx = Univ.instantiate_univ_context (Environ.constant_context env con) in
   let u = Univ.UContext.instance ctx in
@@ -213,13 +220,10 @@ let compute_canonical_projections (con,ind) =
 		   let patt, n , args = cs_pattern_of_constr t in
 		     ((ConstRef proji_sp, patt, t, n, args) :: l)
 		 with Not_found ->
-                   if Flags.is_verbose () then
-                     (let con_pp = Nametab.pr_global_env Id.Set.empty (ConstRef con)
+                     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
+                     if warn then warn_projection_no_head_constant (t,con_pp,proji_sp_pp);
+                   l
 	       end
 	   | _ -> l)
       [] lps in
@@ -235,9 +239,15 @@ let pr_cs_pattern = function
   | Default_cs -> str "_"
   | Sort_cs s -> Termops.pr_sort_family s
 
-let open_canonical_structure i (_,o) =
-  if Int.equal i 1 then
-    let lo = compute_canonical_projections o in
+let warn_redundant_canonical_projection =
+  CWarnings.create ~name:"redundant-canonical-projection" ~category:"typechecker"
+         (fun (hd_val,prj,new_can_s,old_can_s) ->
+          strbrk "Ignoring canonical projection to " ++ hd_val
+          ++ strbrk " by " ++ prj ++ strbrk " in "
+          ++ new_can_s ++ strbrk ": redundant with " ++ old_can_s)
+
+let add_canonical_structure warn o =
+    let lo = compute_canonical_projections warn o in
     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 (assoc_pat cs_pat l)
@@ -245,17 +255,18 @@ let open_canonical_structure i (_,o) =
       in match ocs with
         | 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 Id.Set.empty proj)
               and hd_val = (pr_cs_pattern cs_pat) in
-              msg_warning (strbrk "Ignoring canonical projection to " ++ hd_val
-                             ++ strbrk " by " ++ prj ++ strbrk " in "
-                             ++ new_can_s ++ strbrk ": redundant with " ++ old_can_s)) lo
+              if warn then warn_redundant_canonical_projection (hd_val,prj,new_can_s,old_can_s))
+          lo
+
+let open_canonical_structure i (_, o) =
+  if Int.equal i 1 then add_canonical_structure false o
 
-let cache_canonical_structure o =
-  open_canonical_structure 1 o
+let cache_canonical_structure (_, o) =
+  add_canonical_structure true o
 
 let subst_canonical_structure (subst,(cst,ind as obj)) =
   (* invariant: cst is an evaluable reference. Thus we can take *)
@@ -299,7 +310,7 @@ let check_and_decompose_canonical_structure ref =
     | 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
+  let ntrue_projs = List.count snd s.s_PROJKIND in
   if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then
     error_not_structure ref;
   (sp,indsp)
@@ -317,7 +328,7 @@ let is_open_canonical_projection env sigma (c,args) =
     (** 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 (Stack.nth args n) in
+      let arg = whd_all env sigma (Stack.nth args n) in
       let hd = match kind_of_term arg with App (hd, _) -> hd | _ -> arg in
       not (isConstruct hd)
     with Failure _ -> false
diff --git a/pretyping/redops.ml b/pretyping/redops.ml
index c188995a..7d65925e 100644
--- a/pretyping/redops.ml
+++ b/pretyping/redops.ml
@@ -14,25 +14,29 @@ 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
+    | FMatch :: lf -> add_flag { red with rMatch = true } lf
+    | FFix :: lf -> add_flag { red with rFix = true } lf
+    | FCofix :: lf -> add_flag { red with rCofix = true } lf
     | FZeta :: lf -> add_flag { red with rZeta = true } lf
     | FConst l :: lf ->
 	if red.rDelta then
-	  Errors.error
+	  CErrors.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
+	  CErrors.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 = []}
+    {rBeta = false; rMatch = false; rFix = false; rCofix = false;
+     rZeta = false; rDelta = false; rConst = []}
     l
 
 
 let all_flags =
-  {rBeta = true; rIota = true; rZeta = true; rDelta = true; rConst = []}
+  {rBeta = true; rMatch = true; rFix = true; rCofix = true;
+   rZeta = true; rDelta = true; rConst = []}
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 13b7fb40..297f0a1a 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -6,16 +6,16 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Term
 open Vars
-open Context
 open Termops
 open Univ
 open Evd
 open Environ
+open Context.Rel.Declaration
 
 exception Elimconst
 
@@ -26,6 +26,19 @@ exception Elimconst
     their parameters in its stack.
 *)
 
+let refolding_in_reduction = ref false
+let _ = Goptions.declare_bool_option {
+  Goptions.optsync = true; Goptions.optdepr = false;
+  Goptions.optname =
+    "Perform refolding of fixpoints/constants like cbn during reductions";
+  Goptions.optkey = ["Refolding";"Reduction"];
+  Goptions.optread = (fun () -> !refolding_in_reduction);
+  Goptions.optwrite = (fun a -> refolding_in_reduction:=a);
+}
+
+let get_refolding_in_reduction () = !refolding_in_reduction
+let set_refolding_in_reduction = (:=) refolding_in_reduction
+
 (** Machinery to custom the behavior of the reduction *)
 module ReductionBehaviour = struct
   open Globnames
@@ -153,9 +166,6 @@ module Cst_stack = struct
   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
@@ -164,9 +174,9 @@ module Cst_stack = struct
     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, q)
       | (c,params,(i,t)::q) ->
-	let () = sanity h t.(i) in (c, params, (succ i,t)::q)
+	(c, params, (succ i,t)::q)
     in
       drop_useless (List.map append2cst cst_l)
 
@@ -573,7 +583,7 @@ 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 e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma }
 
 type  contextual_stack_reduction_function =
     env ->  evar_map -> constr -> constr * constr list
@@ -594,9 +604,7 @@ let pr_state (tm,sk) =
 (*** Reduction Functions Operators ***)
 (*************************************)
 
-let safe_evar_value sigma ev =
-  try Some (Evd.existential_value sigma ev)
-  with NotInstantiatedEvar | Not_found -> None
+let safe_evar_value = Evarutil.safe_evar_value
 
 let safe_meta_value sigma ev =
   try Some (Evd.meta_value sigma ev)
@@ -608,7 +616,7 @@ let strong whdfun env sigma t =
   strongrec env t
 
 let local_strong whdfun sigma =
-  let rec strongrec t = map_constr strongrec (whdfun sigma t) in
+  let rec strongrec t = Constr.map strongrec (whdfun sigma t) in
   strongrec
 
 let rec strong_prodspine redfun sigma c =
@@ -621,36 +629,21 @@ let rec strong_prodspine redfun sigma c =
 (*** Reduction using bindingss ***)
 (*************************************)
 
-(* Local *)
-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 = 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
+let eta = CClosure.RedFlags.mkflags [CClosure.RedFlags.fETA]
 
 (* Beta Reduction tools *)
 
-let apply_subst recfun env cst_l t stack =
+let apply_subst recfun env refold 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
+       let cst_l' = if refold then Cst_stack.add_param h cst_l else cst_l in
+       aux (h::env) 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
+  apply_subst (fun _ -> recfun) env false Cst_stack.empty t stack
 
 let beta_applist (c,l) =
   stacklam Stack.zip [] c (Stack.append_app_list l Stack.empty)
@@ -715,11 +708,16 @@ let contract_cofix ?env ?reference (bodynum,(names,types,bodies as typedbodies))
   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
+let reduce_and_refold_cofix recfun env refold cst_l cofix sk =
+  let raw_answer =
+    let env = if refold then Some env else None in
+    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
+    (fun x (t,sk') ->
+      let t' =
+        if refold then Cst_stack.best_replace (mkCoFix cofix) cst_l t else t in
+      recfun x (t',sk'))
+    [] refold Cst_stack.empty raw_answer sk
 
 let reduce_mind_case mia =
   match kind_of_term mia.mconstr with
@@ -755,11 +753,18 @@ let contract_fix ?env ?reference ((recindices,bodynum),(names,types,bodies as ty
     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
+let reduce_and_refold_fix recfun env refold cst_l fix sk =
+  let raw_answer =
+    let env = if refold then None else Some env in
+    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
+    (fun x (t,sk') ->
+      let t' =
+        if refold then
+          Cst_stack.best_replace (mkFix fix) cst_l t
+        else t
+      in recfun x (t',sk'))
+    [] refold Cst_stack.empty raw_answer sk
 
 let fix_recarg ((recindices,bodynum),_) stack =
   assert (0 <= bodynum && bodynum < Array.length recindices);
@@ -799,28 +804,31 @@ let equal_stacks (x, l) (y, l') =
     | None -> false
     | Some (lft1,lft2) -> f_equal (x, lft1) (y, lft2) 
 
-let rec whd_state_gen ?csts tactic_mode flags env sigma =
+let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma =
+  let open Context.Named.Declaration in
   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 ++
+	Feedback.msg_notice
+             (h 0 (str "<<" ++ Termops.print_constr x ++
 		   str "|" ++ cut () ++ Cst_stack.pr cst_l ++
 		   str "|" ++ cut () ++ Stack.pr Termops.print_constr stack ++
-		   str ">>") ++ fnl ())
+		   str ">>"))
     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)
+	  let open Pp in Feedback.msg_notice (str "<><><><><>") in
+      (s,cst_l)
     in
     match kind_of_term x with
-    | Rel n when Closure.RedFlags.red_set flags Closure.RedFlags.fDELTA ->
+    | Rel n when CClosure.RedFlags.red_set flags CClosure.RedFlags.fDELTA ->
       (match lookup_rel n env with
-      | (_,Some body,_) -> whrec Cst_stack.empty (lift n body, stack)
+      | LocalDef (_,body,_) -> whrec Cst_stack.empty (lift n body, stack)
       | _ -> fold ())
-    | Var id when Closure.RedFlags.red_set flags (Closure.RedFlags.fVAR id) ->
+    | Var id when CClosure.RedFlags.red_set flags (CClosure.RedFlags.fVAR id) ->
       (match lookup_named id env with
-      | (_,Some body,_) -> whrec (Cst_stack.add_cst (mkVar id) cst_l) (body, stack)
+      | LocalDef (_,body,_) ->
+	whrec (if refold then Cst_stack.add_cst (mkVar id) cst_l else cst_l) (body, stack)
       | _ -> fold ())
     | Evar ev ->
       (match safe_evar_value sigma ev with
@@ -830,12 +838,13 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
       (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) ->
+    | Const (c,u as const) when CClosure.RedFlags.red_set flags (CClosure.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)
+	   then whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else 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)
@@ -870,7 +879,7 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
 		      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 ->
+    | Proj (p, c) when CClosure.RedFlags.red_projection flags p ->
       (let pb = lookup_projection p env in
        let kn = Projection.constant p in
        let npars = pb.Declarations.proj_npars 
@@ -911,21 +920,21 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
 		       (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
+    | LetIn (_,b,_,c) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fZETA ->
+      apply_subst whrec [b] refold cst_l c stack
     | Cast (c,_,_) -> whrec cst_l (c, stack)
     | App (f,cl)  ->
       whrec
-	(Cst_stack.add_args cl cst_l)
+	(if refold then Cst_stack.add_args cl cst_l else 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
+      | Some _ when CClosure.RedFlags.red_set flags CClosure.RedFlags.fBETA ->
+	apply_subst whrec [] refold cst_l x stack
+      | None when CClosure.RedFlags.red_set flags CClosure.RedFlags.fETA ->
+	let env' = push_rel (LocalAssum (na,t)) env in
+	let whrec' = whd_state_gen ~refold ~tactic_mode flags env' sigma in
+        (match kind_of_term (Stack.zip ~refold (fst (whrec' (c, Stack.empty)))) with
         | App (f,cl) ->
 	  let napp = Array.length cl in
 	  if napp > 0 then
@@ -950,16 +959,18 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
 	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
+      let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in
+      let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in
+      if use_match || use_fix then
 	match Stack.strip_app stack with
-	|args, (Stack.Case(ci, _, lf,_)::s') ->
+	|args, (Stack.Case(ci, _, lf,_)::s') when use_match ->
 	  whrec Cst_stack.empty (lf.(c-1), (Stack.tail ci.ci_npar args) @ s')
-	|args, (Stack.Proj (n,m,p,_)::s') ->
+	|args, (Stack.Proj (n,m,p,_)::s') when use_match ->
 	  whrec Cst_stack.empty (Stack.nth args (n+m), s')
-	|args, (Stack.Fix (f,s',cst_l)::s'') ->
+	|args, (Stack.Fix (f,s',cst_l)::s'') when use_fix ->
 	  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
+	  reduce_and_refold_fix whrec env refold 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
@@ -969,7 +980,7 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
 	      (match constant_opt_value_in env const with
 	      | None -> fold ()
 	      | Some body ->
-		whrec (Cst_stack.add_cst (mkConstU const) cst_l)
+		whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l)
 		  (body, s' @ (Stack.append_app [|x'|] s'')))
 	    | Stack.Cst_proj p ->
 	      let pb = lookup_projection p env in
@@ -988,35 +999,37 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
 		 Stack.Cst (const,next,remains',s' @ (Stack.append_app [|x'|] bef),cst_l) :: s''')
 	  end
 	|_, (Stack.App _|Stack.Update _|Stack.Shift _)::_ -> assert false
-	|_, [] -> fold ()
+	|_, _ -> fold ()
       else fold ()
 
     | CoFix cofix ->
-      if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then
+      if CClosure.RedFlags.red_set flags CClosure.RedFlags.fCOFIX then
 	match Stack.strip_app stack with
 	|args, ((Stack.Case _ |Stack.Proj _)::s') ->
-	  reduce_and_refold_cofix whrec env cst_l cofix stack
+	  reduce_and_refold_cofix whrec env refold cst_l cofix stack
 	|_ -> fold ()
       else fold ()
 
     | Rel _ | Var _ | Const _ | LetIn _ | Proj _ -> fold ()
     | Sort _ | Ind _ | Prod _ -> fold ()
   in
-  whrec (Option.default Cst_stack.empty csts)
+  fun xs ->
+  let (s,cst_l as res) = whrec (Option.default Cst_stack.empty csts) xs in
+  if tactic_mode then (Stack.best_state s cst_l,Cst_stack.empty) else res
 
 (** 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 Closure.RedFlags.red_set flags Closure.RedFlags.fZETA ->
+    | LetIn (_,b,_,c) when CClosure.RedFlags.red_set flags CClosure.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 ->
+      | Some (a,m) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fBETA ->
 	stacklam whrec [a] c m
-      | None when Closure.RedFlags.red_set flags Closure.RedFlags.fETA ->
+      | None when CClosure.RedFlags.red_set flags CClosure.RedFlags.fETA ->
         (match kind_of_term (Stack.zip (whrec (c, Stack.empty))) with
         | App (f,cl) ->
 	  let napp = Array.length cl in
@@ -1032,7 +1045,7 @@ let local_whd_state_gen flags sigma =
 	| _ -> s)
       | _ -> s)
 
-    | Proj (p,c) when Closure.RedFlags.red_projection flags p ->
+    | Proj (p,c) when CClosure.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)
@@ -1057,21 +1070,23 @@ let local_whd_state_gen flags sigma =
       | None -> s)
 
     | Construct ((ind,c),u) ->
-      if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then
+      let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in
+      let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in
+      if use_match || use_fix then
 	match Stack.strip_app stack with
-	|args, (Stack.Case(ci, _, lf,_)::s') ->
+	|args, (Stack.Case(ci, _, lf,_)::s') when use_match ->
 	  whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s')
-	|args, (Stack.Proj (n,m,p,_) :: s') ->
+	|args, (Stack.Proj (n,m,p,_) :: s') when use_match ->
 	  whrec (Stack.nth args (n+m), s')
-	|args, (Stack.Fix (f,s',cst)::s'') ->
+	|args, (Stack.Fix (f,s',cst)::s'') when use_fix ->
 	  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
+	|_, _ -> s
       else s
 
     | CoFix cofix ->
-      if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then
+      if CClosure.RedFlags.red_set flags CClosure.RedFlags.fCOFIX then
 	match Stack.strip_app stack with
 	|args, ((Stack.Case _ | Stack.Proj _)::s') ->
 	  whrec (contract_cofix cofix, stack)
@@ -1083,7 +1098,7 @@ let local_whd_state_gen flags sigma =
   whrec
 
 let raw_whd_state_gen flags env =
-  let f sigma s = fst (whd_state_gen false flags env sigma s) in
+  let f sigma s = fst (whd_state_gen (get_refolding_in_reduction ()) false flags env sigma s) in
   f
 
 let stack_red_of_state_red f =
@@ -1093,7 +1108,7 @@ let stack_red_of_state_red 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 (hd,sk),_ = whd_state_gen refold false flags env sigma (t,Stack.empty) in
   let whd_sk = Stack.map aux sk in
   Stack.zip ~refold (hd,whd_sk)
   in aux s
@@ -1103,109 +1118,72 @@ let red_of_state_red f sigma x =
 
 (* 0. No Reduction Functions *)
 
-let whd_nored_state = local_whd_state_gen nored
+let whd_nored_state = local_whd_state_gen CClosure.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 *)
 
-let whd_beta_state = local_whd_state_gen beta
+let whd_beta_state = local_whd_state_gen CClosure.beta
 let whd_beta_stack = stack_red_of_state_red whd_beta_state
 let whd_beta = red_of_state_red whd_beta_state
 
-(* Nouveau ! *)
-let whd_betaetalet_state = local_whd_state_gen betaetalet
-let whd_betaetalet_stack = stack_red_of_state_red whd_betaetalet_state
-let whd_betaetalet = red_of_state_red whd_betaetalet_state
-
-let whd_betalet_state = local_whd_state_gen betalet
+let whd_betalet_state = local_whd_state_gen CClosure.betazeta
 let whd_betalet_stack = stack_red_of_state_red whd_betalet_state
 let whd_betalet = red_of_state_red whd_betalet_state
 
 (* 2. Delta Reduction Functions *)
 
-let whd_delta_state e = raw_whd_state_gen delta e
+let whd_delta_state e = raw_whd_state_gen CClosure.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 = 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_betadeltazeta_state e = raw_whd_state_gen CClosure.betadeltazeta e
+let whd_betadeltazeta_stack env =
+  stack_red_of_state_red (whd_betadeltazeta_state env)
+let whd_betadeltazeta env =
+  red_of_state_red (whd_betadeltazeta_state env)
 
 
-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 =
-  red_of_state_red (whd_betadeltaeta_state env)
-
 (* 3. Iota reduction Functions *)
 
-let whd_betaiota_state = local_whd_state_gen betaiota
+let whd_betaiota_state = local_whd_state_gen CClosure.betaiota
 let whd_betaiota_stack = stack_red_of_state_red whd_betaiota_state
 let whd_betaiota = red_of_state_red whd_betaiota_state
 
-let whd_betaiotazeta_state = local_whd_state_gen betaiotazeta
+let whd_betaiotazeta_state = local_whd_state_gen CClosure.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 = 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_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_all_state env = raw_whd_state_gen CClosure.all env
+let whd_all_stack env =
+  stack_red_of_state_red (whd_all_state env)
+let whd_all env =
+  red_of_state_red (whd_all_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 =
-  red_of_state_red (whd_betadeltaiota_nolet_state env)
+let whd_allnolet_state env = raw_whd_state_gen CClosure.allnolet env
+let whd_allnolet_stack env =
+  stack_red_of_state_red (whd_allnolet_state env)
+let whd_allnolet env =
+  red_of_state_red (whd_allnolet_state env)
 
-(* 4. Eta reduction Functions *)
+(* 4. Ad-hoc eta reduction, does not subsitute evars *)
 
-let whd_eta c = Stack.zip (local_whd_state_gen eta Evd.empty (c,Stack.empty))
+let shrink_eta c = Stack.zip (local_whd_state_gen eta Evd.empty (c,Stack.empty))
 
 (* 5. Zeta Reduction Functions *)
 
-let whd_zeta c = Stack.zip (local_whd_state_gen zeta Evd.empty (c,Stack.empty))
+let whd_zeta_state = local_whd_state_gen CClosure.zeta
+let whd_zeta_stack = stack_red_of_state_red whd_zeta_state
+let whd_zeta = red_of_state_red whd_zeta_state
 
 (****************************************************************************)
 (*                   Reduction Functions                                    *)
 (****************************************************************************)
 
 (* Replacing defined evars for error messages *)
-let rec whd_evar sigma c =
-  match kind_of_term c with
-    | Evar ev ->
-        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 (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 =
-  local_strong whd_evar
+let whd_evar = Evarutil.whd_evar
+let nf_evar = Evarutil.nf_evar
 
 (* lazy reduction functions. The infos must be created for each term *)
 (* Note by HH [oct 08] : why would it be the job of clos_norm_flags to add
@@ -1213,16 +1191,16 @@ let nf_evar =
 let clos_norm_flags flgs env sigma t =
   try
     let evars ev = safe_evar_value sigma ev in
-    Closure.norm_val
-      (Closure.create_clos_infos ~evars flgs env)
-      (Closure.inject t)
+    CClosure.norm_val
+      (CClosure.create_clos_infos ~evars flgs env)
+      (CClosure.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
+let nf_beta = clos_norm_flags CClosure.beta (Global.env ())
+let nf_betaiota = clos_norm_flags CClosure.betaiota (Global.env ())
+let nf_betaiotazeta = clos_norm_flags CClosure.betaiotazeta (Global.env ())
+let nf_all env sigma =
+  clos_norm_flags CClosure.all env sigma
 
 
 (********************************************************************)
@@ -1253,31 +1231,29 @@ let pb_equal = function
 
 let report_anomaly _ =
   let e = UserError ("", Pp.str "Conversion test raised an anomaly") in
-  let e = Errors.push e in
+  let e = CErrors.push e in
   iraise e
 
-let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y =
+let test_trans_conversion (f: constr Reduction.extended_conversion_function) reds env sigma x y =
   try
     let evars ev = safe_evar_value sigma ev in
-    let _ = f ~evars reds env (Evd.universes sigma) x y in
+    let _ = f ~reds env ~evars:(evars, Evd.universes sigma) x y in
     true
   with Reduction.NotConvertible -> false
     | e when is_anomaly e -> report_anomaly e
 
-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 is_conv ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv reds env sigma
+let is_conv_leq ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv_leq reds env sigma
+let is_fconv ?(reds=full_transparent_state) = function
+  | Reduction.CONV -> is_conv ~reds
+  | Reduction.CUMUL -> is_conv_leq ~reds
 
 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 
+    | Reduction.CONV -> Reduction.conv
+    | Reduction.CUMUL -> Reduction.conv_leq
   in
-    try f ~evars:(safe_evar_value sigma) ts env (Evd.universes sigma) x y; true
+    try f ~reds:ts env ~evars:(safe_evar_value sigma, Evd.universes sigma) x y; true
     with Reduction.NotConvertible -> false
     | Univ.UniverseInconsistency _ -> false
     | e when is_anomaly e -> report_anomaly e
@@ -1286,7 +1262,7 @@ 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
@@ -1299,18 +1275,21 @@ let sigma_univ_state =
 
 let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL)
     ?(ts=full_transparent_state) env sigma x y =
-  try 
+  try
+    let fold cstr sigma =
+      try Some (Evd.add_universe_constraints sigma cstr)
+      with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> None
+    in
     let b, sigma = 
-      let b, cstrs = 
+      let ans =
 	if pb == Reduction.CUMUL then 
-	  Universes.leq_constr_univs_infer (Evd.universes sigma) x y 
+	  Universes.leq_constr_univs_infer (Evd.universes sigma) fold x y sigma
 	else
-	  Universes.eq_constr_univs_infer (Evd.universes sigma) x y 
+	  Universes.eq_constr_univs_infer (Evd.universes sigma) fold x y sigma
       in
-	if b then 
-	  try true, Evd.add_universe_constraints sigma cstrs
-	  with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> false, sigma
-	else false, sigma
+      match ans with
+      | None -> false, sigma
+      | Some sigma -> true, sigma
     in
       if b then sigma, true
       else
@@ -1416,7 +1395,7 @@ let instance sigma s c =
  * error message. *)
 
 let hnf_prod_app env sigma t n =
-  match kind_of_term (whd_betadeltaiota env sigma t) with
+  match kind_of_term (whd_all env sigma t) with
     | Prod (_,_,b) -> subst1 n b
     | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product")
 
@@ -1427,7 +1406,7 @@ let hnf_prod_applist env sigma t nl =
   List.fold_left (hnf_prod_app env sigma) t nl
 
 let hnf_lam_app env sigma t n =
-  match kind_of_term (whd_betadeltaiota env sigma t) with
+  match kind_of_term (whd_all env sigma t) with
     | Lambda (_,_,b) -> subst1 n b
     | _ -> anomaly ~label:"hnf_lam_app" (Pp.str "Need an abstraction")
 
@@ -1439,10 +1418,10 @@ let hnf_lam_applist env sigma t nl =
 
 let splay_prod env sigma =
   let rec decrec env m c =
-    let t = whd_betadeltaiota env sigma c in
+    let t = whd_all env sigma c in
     match kind_of_term t with
       | Prod (n,a,c0) ->
-	  decrec (push_rel (n,None,a) env)
+	  decrec (push_rel (LocalAssum (n,a)) env)
 	    ((n,a)::m) c0
       | _ -> m,t
   in
@@ -1450,10 +1429,10 @@ let splay_prod env sigma =
 
 let splay_lam env sigma =
   let rec decrec env m c =
-    let t = whd_betadeltaiota env sigma c in
+    let t = whd_all env sigma c in
     match kind_of_term t with
       | Lambda (n,a,c0) ->
-	  decrec (push_rel (n,None,a) env)
+	  decrec (push_rel (LocalAssum (n,a)) env)
 	    ((n,a)::m) c0
       | _ -> m,t
   in
@@ -1461,21 +1440,21 @@ let splay_lam env sigma =
 
 let splay_prod_assum env sigma =
   let rec prodec_rec env l c =
-    let t = whd_betadeltaiota_nolet env sigma c in
+    let t = whd_allnolet env sigma c in
     match kind_of_term t with
     | Prod (x,t,c)  ->
-	prodec_rec (push_rel (x,None,t) env)
-	  (add_rel_decl (x, None, t) l) c
+	prodec_rec (push_rel (LocalAssum (x,t)) env)
+	  (Context.Rel.add (LocalAssum (x,t)) l) c
     | LetIn (x,b,t,c) ->
-	prodec_rec (push_rel (x, Some b, t) env)
-	  (add_rel_decl (x, Some b, t) l) c
+	prodec_rec (push_rel (LocalDef (x,b,t)) env)
+	  (Context.Rel.add (LocalDef (x,b,t)) l) c
     | Cast (c,_,_)    -> prodec_rec env l c
     | _               -> 
-      let t' = whd_betadeltaiota env sigma t in
+      let t' = whd_all 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
+  prodec_rec env Context.Rel.empty
 
 let splay_arity env sigma c =
   let l, c = splay_prod env sigma c in
@@ -1487,26 +1466,26 @@ 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 Int.equal m 0 then (ln,c) else
-    match kind_of_term (whd_betadeltaiota env sigma c) with
+    match kind_of_term (whd_all env sigma c) with
       | Prod (n,a,c0) ->
-	  decrec (push_rel (n,None,a) env)
-	    (m-1) (add_rel_decl (n,None,a) ln) c0
+	  decrec (push_rel (LocalAssum (n,a)) env)
+	    (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0
       | _                      -> invalid_arg "splay_prod_n"
   in
-  decrec env n empty_rel_context
+  decrec env n Context.Rel.empty
 
 let splay_lam_n env sigma n =
   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
+    match kind_of_term (whd_all env sigma c) with
       | Lambda (n,a,c0) ->
-	  decrec (push_rel (n,None,a) env)
-	    (m-1) (add_rel_decl (n,None,a) ln) c0
+	  decrec (push_rel (LocalAssum (n,a)) env)
+	    (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0
       | _                      -> invalid_arg "splay_lam_n"
   in
-  decrec env n empty_rel_context
+  decrec env n Context.Rel.empty
 
 let is_sort env sigma t =
-  match kind_of_term (whd_betadeltaiota env sigma t) with
+  match kind_of_term (whd_all env sigma t) with
   | Sort s -> true
   | _ -> false
 
@@ -1514,20 +1493,22 @@ let is_sort env sigma t =
    of case/fix (heuristic used by evar_conv) *)
 
 let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s =
+  let refold = get_refolding_in_reduction () in
+  let tactic_mode = false in
   let rec whrec csts s =
-    let (t, stack as s),csts' = whd_state_gen ~csts false betaiota env sigma s in
+    let (t, stack as s),csts' = whd_state_gen ~csts ~refold ~tactic_mode CClosure.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
+	let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode
+	  (CClosure.RedFlags.red_add_transparent CClosure.all 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
+	let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode
+	  (CClosure.RedFlags.red_add_transparent CClosure.all 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
+	let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode
+	  (CClosure.RedFlags.red_add_transparent CClosure.all 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'
@@ -1536,10 +1517,10 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s =
 
 let find_conclusion env sigma =
   let rec decrec env c =
-    let t = whd_betadeltaiota env sigma c in
+    let t = whd_all env sigma c in
     match kind_of_term t with
-      | Prod (x,t,c0) -> decrec (push_rel (x,None,t) env) c0
-      | Lambda (x,t,c0) -> decrec (push_rel (x,None,t) env) c0
+      | Prod (x,t,c0) -> decrec (push_rel (LocalAssum (x,t)) env) c0
+      | Lambda (x,t,c0) -> decrec (push_rel (LocalAssum (x,t)) env) c0
       | t -> t
   in
   decrec env
@@ -1623,7 +1604,7 @@ let meta_reducible_instance evd b =
 	  with
 	    | Some g -> irec (mkProj (p,g))
 	    | None -> mkProj (p,c))
-    | _ -> map_constr irec u
+    | _ -> Constr.map irec u
   in
   if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus
   else irec b.rebus
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index aea0a9ae..4cd7a2a8 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -8,7 +8,6 @@
 
 open Names
 open Term
-open Context
 open Univ
 open Evd
 open Environ
@@ -29,6 +28,11 @@ module ReductionBehaviour : sig
   val print : Globnames.global_reference -> Pp.std_ppcmds
 end
 
+(** Option telling if reduction should use the refolding machinery of cbn
+   (off by default) *)
+val get_refolding_in_reduction : unit -> bool
+val set_refolding_in_reduction : bool -> unit
+
 (** {6 Machinery about a stack of unfolded constant }
 
     cst applied to params must convertible to term of the state applied to args
@@ -109,7 +113,7 @@ 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 e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma }
 
 type contextual_stack_reduction_function =
     env -> evar_map -> constr -> constr * constr list
@@ -135,21 +139,21 @@ val stack_reduction_of_reduction :
 i*)
 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 whd_state_gen : ?csts:Cst_stack.t -> refold:bool -> tactic_mode:bool ->
+  CClosure.RedFlags.reds -> Environ.env -> Evd.evar_map -> state -> state * Cst_stack.t
 
-val iterate_whd_gen : bool -> Closure.RedFlags.reds ->
+val iterate_whd_gen : bool -> CClosure.RedFlags.reds ->
   Environ.env -> Evd.evar_map -> Term.constr -> Term.constr
 
 (** {6 Generic Optimized Reduction Function using Closures } *)
 
-val clos_norm_flags : Closure.RedFlags.reds -> reduction_function
+val clos_norm_flags : CClosure.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_all : reduction_function
 val nf_evar : evar_map -> constr -> constr
 
 (** Lazy strategy, weak head reduction *)
@@ -159,9 +163,8 @@ val whd_nored : local_reduction_function
 val whd_beta : local_reduction_function
 val whd_betaiota : local_reduction_function
 val whd_betaiotazeta : local_reduction_function
-val whd_betadeltaiota :  contextual_reduction_function
-val whd_betadeltaiota_nolet :  contextual_reduction_function
-val whd_betaetalet : local_reduction_function
+val whd_all :  contextual_reduction_function
+val whd_allnolet :  contextual_reduction_function
 val whd_betalet : local_reduction_function
 
 (** Removes cast and put into applicative form *)
@@ -169,18 +172,16 @@ 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
-val whd_betadeltaiota_stack : contextual_stack_reduction_function
-val whd_betadeltaiota_nolet_stack : contextual_stack_reduction_function
-val whd_betaetalet_stack : local_stack_reduction_function
+val whd_all_stack : contextual_stack_reduction_function
+val whd_allnolet_stack : contextual_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
-val whd_betadeltaiota_state : contextual_state_reduction_function
-val whd_betadeltaiota_nolet_state : contextual_state_reduction_function
-val whd_betaetalet_state : local_state_reduction_function
+val whd_all_state : contextual_state_reduction_function
+val whd_allnolet_state : contextual_state_reduction_function
 val whd_betalet_state : local_state_reduction_function
 
 (** {6 Head normal forms } *)
@@ -188,18 +189,14 @@ val whd_betalet_state : local_state_reduction_function
 val whd_delta_stack :  stack_reduction_function
 val whd_delta_state :  state_reduction_function
 val whd_delta :  reduction_function
-val whd_betadelta_stack :  stack_reduction_function
-val whd_betadelta_state :  state_reduction_function
-val whd_betadelta :  reduction_function
-val whd_betadeltaeta_stack :  stack_reduction_function
-val whd_betadeltaeta_state :  state_reduction_function
-val whd_betadeltaeta :  reduction_function
-val whd_betadeltaiotaeta_stack :  stack_reduction_function
-val whd_betadeltaiotaeta_state :  state_reduction_function
-val whd_betadeltaiotaeta :  reduction_function
-
-val whd_eta : constr -> constr
-val whd_zeta : constr -> constr
+val whd_betadeltazeta_stack :  stack_reduction_function
+val whd_betadeltazeta_state :  state_reduction_function
+val whd_betadeltazeta :  reduction_function
+val whd_zeta_stack : local_stack_reduction_function
+val whd_zeta_state : local_state_reduction_function
+val whd_zeta : local_reduction_function
+
+val shrink_eta : constr -> constr
 
 (** Various reduction functions *)
 
@@ -218,11 +215,10 @@ 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_n : env ->  evar_map -> int -> constr -> Context.Rel.t * constr
+val splay_lam_n : env ->  evar_map -> int -> constr -> Context.Rel.t * constr
 val splay_prod_assum :
-  env ->  evar_map -> constr -> rel_context * constr
-val is_sort : env -> evar_map -> types -> bool
+  env ->  evar_map -> constr -> Context.Rel.t * constr
 
 type 'a miota_args = {
   mP      : constr;     (** the result type *)
@@ -251,13 +247,9 @@ type conversion_test = constraints -> constraints
 val pb_is_equal : conv_pb -> bool
 val pb_equal : conv_pb -> conv_pb
 
-val is_conv : env ->  evar_map -> constr -> constr -> bool
-val is_conv_leq : env ->  evar_map -> constr -> constr -> bool
-val is_fconv : conv_pb -> env ->  evar_map -> constr -> constr -> bool
-
-val is_trans_conv : transparent_state -> env -> evar_map -> constr -> constr -> bool
-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
+val is_conv : ?reds:transparent_state -> env -> evar_map -> constr -> constr -> bool
+val is_conv_leq : ?reds:transparent_state -> env ->  evar_map -> constr -> constr -> bool
+val is_fconv : ?reds:transparent_state -> conv_pb -> env ->  evar_map -> constr -> constr -> bool
 
 (** [check_conv] Checks universe constraints only.
     pb defaults to CUMUL and ts to a full transparent state.
diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
index cb4e588e..98b36fb9 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Term
 open Vars
@@ -18,6 +18,7 @@ open Reductionops
 open Environ
 open Termops
 open Arguments_renaming
+open Context.Rel.Declaration
 
 type retype_error =
   | NotASort
@@ -61,7 +62,7 @@ let get_type_from_constraints env sigma t =
 let rec subst_type env sigma typ = function
   | [] -> typ
   | h::rest ->
-      match kind_of_term (whd_betadeltaiota env sigma typ) with
+      match kind_of_term (whd_all env sigma typ) with
         | Prod (na,c1,c2) -> subst_type env sigma (subst1 h c2) rest
         | _ -> retype_error NonFunctionalConstruction
 
@@ -70,29 +71,30 @@ let rec subst_type env sigma typ = function
 
 let sort_of_atomic_type env sigma ft 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 (lift n h),t) env) (n + 1) b l
+    match kind_of_term (whd_all env sigma ar), args with
+    | Prod (na, t, b), h::l -> concl_of_arity (push_rel (LocalDef (na, lift n h, t)) env) (n + 1) b l
     | Sort s, [] -> s
     | _ -> 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
+  let open Context.Named.Declaration in
+  try get_type (lookup_named id env)
   with Not_found -> retype_error (BadVariable id)
 
 let decomp_sort env sigma t =
-  match kind_of_term (whd_betadeltaiota env sigma t) with
+  match kind_of_term (whd_all env sigma t) with
   | Sort s -> s
   | _ -> retype_error NotASort
 
 let retype ?(polyprop=true) sigma =
-  let rec type_of env cstr=
+  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 -> retype_error (BadMeta n))
     | Rel n ->
-        let (_,_,ty) = lookup_rel n env in
+	let ty = get_type (lookup_rel n env) in
         lift n ty
     | Var id -> type_of_var env id
     | Const cst -> rename_type_of_constant env cst
@@ -111,13 +113,13 @@ let retype ?(polyprop=true) sigma =
         in
         let n = inductive_nrealdecls_env env (fst (fst (dest_ind_family indf))) in
         let t = betazetaevar_applist sigma n p realargs in
-        (match kind_of_term (whd_betadeltaiota env sigma (type_of env t)) with
+        (match kind_of_term (whd_all env sigma (type_of env t)) with
           | Prod _ -> whd_beta sigma (applist (t, [c]))
           | _ -> t)
     | Lambda (name,c1,c2) ->
-          mkProd (name, c1, type_of (push_rel (name,None,c1) env) c2)
+          mkProd (name, c1, type_of (push_rel (LocalAssum (name,c1)) env) c2)
     | LetIn (name,b,c1,c2) ->
-         subst1 b (type_of (push_rel (name,Some b,c1) env) c2)
+         subst1 b (type_of (push_rel (LocalDef (name,b,c1)) env) c2)
     | Fix ((_,i),(_,tys,_)) -> tys.(i)
     | CoFix (i,(_,tys,_)) -> tys.(i)
     | App(f,args) when is_template_polymorphic env f ->
@@ -140,7 +142,7 @@ let retype ?(polyprop=true) sigma =
     | Sort (Prop c) -> type1_sort
     | Sort (Type u) -> Type (Univ.super u)
     | Prod (name,t,c2) ->
-        (match (sort_of env t, sort_of (push_rel (name,None,t) env) c2) with
+        (match (sort_of env t, sort_of (push_rel (LocalAssum (name,t)) env) c2) with
 	  | _, (Prop Null as s) -> s
           | Prop _, (Prop Pos as s) -> s
           | Type _, (Prop Pos as s) when is_impredicative_set env -> s
@@ -161,7 +163,7 @@ let retype ?(polyprop=true) sigma =
     | Sort (Prop c) -> InType
     | Sort (Type u) -> InType
     | Prod (name,t,c2) ->
-	let s2 = sort_family_of (push_rel (name,None,t) env) c2 in
+	let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in
 	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 ->
@@ -235,9 +237,9 @@ let get_judgment_of env evc c = { uj_val = c; uj_type = get_type_of env evc c }
 let sorts_of_context env evc ctxt =
   let rec aux = function
   | [] -> env,[]
-  | (_,_,t as d)::ctxt ->
+  | d :: ctxt ->
       let env,sorts = aux ctxt in
-      let s = get_sort_of env evc t in
+      let s = get_sort_of env evc (get_type d) in
       (push_rel d env,s::sorts) in
   snd (aux ctxt)
 
diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli
index 37cec0c6..8ca40f82 100644
--- a/pretyping/retyping.mli
+++ b/pretyping/retyping.mli
@@ -8,7 +8,6 @@
 
 open Term
 open Evd
-open Context
 open Environ
 
 (** This family of functions assumes its constr argument is known to be
@@ -44,6 +43,8 @@ val type_of_global_reference_knowing_parameters : env -> evar_map -> constr ->
 val type_of_global_reference_knowing_conclusion :
   env -> evar_map -> constr -> types -> evar_map * types
 
-val sorts_of_context : env -> evar_map -> rel_context -> sorts list
+val sorts_of_context : env -> evar_map -> Context.Rel.t -> sorts list
 
 val expand_projection : env -> evar_map -> Names.projection -> constr -> constr list -> constr
+
+val print_retype_error : retype_error -> Pp.std_ppcmds
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index 7c4f28ca..820a81b5 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Term
@@ -18,11 +18,12 @@ open Termops
 open Find_subterm
 open Namegen
 open Environ
-open Closure
+open CClosure
 open Reductionops
 open Cbv
 open Patternops
 open Locus
+open Sigma.Notations
 
 (* Errors *)
 
@@ -53,12 +54,13 @@ let is_evaluable env = function
   | EvalVarRef id -> is_evaluable_var env id
 
 let value_of_evaluable_ref env evref u =
+  let open Context.Named.Declaration in
   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))
+  | EvalVarRef id -> lookup_named id env |> get_value |> Option.get
 
 let evaluable_of_global_reference env = function
   | ConstRef cst when is_evaluable_const env cst -> EvalConstRef cst
@@ -103,29 +105,29 @@ let destEvalRefU c = match kind_of_term c with
   | Evar ev -> (EvalEvar ev, Univ.Instance.empty)
   | _ -> anomaly (Pp.str "Not an unfoldable reference")
 
-let unsafe_reference_opt_value env sigma eval = 
+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
+      let open Context.Named.Declaration in
+      lookup_named id env |> get_value
   | EvalRel n ->
-      let (_,v,_) = lookup_rel n env in
-      Option.map (lift n) v
+      let open Context.Rel.Declaration in
+      lookup_rel n env |> map_value (lift n) |> get_value
   | EvalEvar ev -> Evd.existential_opt_value sigma ev
 
 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
+      let open Context.Named.Declaration in
+      lookup_named id env |> get_value
   | EvalRel n ->
-      let (_,v,_) = lookup_rel n env in
-      Option.map (lift n) v
+      let open Context.Rel.Declaration in
+      lookup_rel n env |> map_value (lift n) |> get_value
   | EvalEvar ev -> Evd.existential_opt_value sigma ev
 
 exception NotEvaluable
@@ -255,10 +257,11 @@ let invert_name labs l na0 env sigma ref = function
 
 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
+    let c',l = whd_betadeltazeta_stack env sigma c in
     match kind_of_term c' with
       | Lambda (id,t,g) when List.is_empty l && not onlyproj ->
-	  srec (push_rel (id,None,t) env) (n+1) (t::labs) onlyproj g
+          let open Context.Rel.Declaration in
+	  srec (push_rel (LocalAssum (id,t)) env) (n+1) (t::labs) onlyproj g
       | Fix fix when not onlyproj ->
 	  (try check_fix_reversibility labs l fix
 	  with Elimconst -> NotAnElimination)
@@ -277,7 +280,8 @@ let compute_consteval_mutual_fix env sigma ref =
     let nargs = List.length l in
     match kind_of_term c' with
       | Lambda (na,t,g) when List.is_empty l ->
-	  srec (push_rel (na,None,t) env) (minarg+1) (t::labs) ref g
+          let open Context.Rel.Declaration in
+	  srec (push_rel (LocalAssum (na,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 env sigma ref with
@@ -371,7 +375,8 @@ let make_elim_fun (names,(nbfix,lv,n)) u largs =
 let dummy = mkProp
 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)]
+let venv = let open Context.Named.Declaration in
+           val_of_named_context [LocalAssum (vfx, dummy); LocalAssum (vfun, dummy)]
 
 (* Mark every occurrence of substituted vars (associated to a function)
    as a problem variable: an evar that can be instantiated either by
@@ -385,7 +390,9 @@ let substl_with_function subst sigma constr =
     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
+        let sigma = Sigma.Unsafe.of_evar_map !evd in
+        let Sigma (evk, sigma, _) = Evarutil.new_pure_evar venv sigma dummy in
+        let sigma = Sigma.to_evar_map sigma in
         evd := sigma;
         minargs := Evar.Map.add evk min !minargs;
         lift k (mkEvar (evk, [|fx;ref|]))
@@ -534,9 +541,11 @@ let match_eval_ref_value env sigma constr =
   | 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
+     let open Context.Named.Declaration in
+     lookup_named id env |> get_value
+  | Rel n ->
+     let open Context.Rel.Declaration in
+     lookup_rel n env |> map_value (lift n) |> get_value
   | Evar ev -> Evd.existential_opt_value sigma ev
   | _ -> None
 
@@ -601,12 +610,14 @@ let whd_nothing_for_iota env sigma s =
   let rec whrec (x, stack as s) =
     match kind_of_term x with
       | Rel n ->
+          let open Context.Rel.Declaration in
 	  (match lookup_rel n env with
-	     | (_,Some body,_) -> whrec (lift n body, stack)
+	     | LocalDef (_,body,_) -> whrec (lift n body, stack)
 	     | _ -> s)
       | Var id ->
+          let open Context.Named.Declaration in
 	  (match lookup_named id env with
-	     | (_,Some body,_) -> whrec (body, stack)
+	     | LocalDef (_,body,_) -> whrec (body, stack)
 	     | _ -> s)
       | Evar ev ->
 	(try whrec (Evd.existential_value sigma ev, stack)
@@ -809,7 +820,9 @@ let try_red_product env sigma c =
                         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)
+      | Prod (x,a,b) ->
+          let open Context.Rel.Declaration in
+	  mkProd (x, a, redrec (push_rel (LocalAssum (x,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))
       | Proj (p, c) -> 
@@ -857,7 +870,7 @@ let red_product env sigma c =
  *)
 
 let whd_simpl_orelse_delta_but_fix_old env sigma c =
-  let whd_all = whd_betadeltaiota_state env sigma in
+  let whd_all = whd_all_state env sigma in
   let rec redrec (x, stack as s) =
     match kind_of_term x with
       | Lambda (na,t,c) ->
@@ -940,8 +953,6 @@ let matches_head env sigma c t =
     | 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
-
 (** 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.
@@ -962,10 +973,12 @@ let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c =
       | _ -> 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 e_contextually byhead (occs,c) f = { e_redfun = begin fun 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 sigma = Sigma.to_evar_map sigma in
+  (** FIXME: we do suspicious things with this evarmap *)
   let evd = ref sigma in
   let rec traverse nested (env,c as envc) t =
     if nowhere_except_in && (!pos > maxocc) then (* Shortcut *) t
@@ -984,8 +997,8 @@ let e_contextually byhead (occs,c) f env sigma t =
         (* 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)
+	let Sigma (t, evm, _) = (f subst).e_redfun env (Sigma.Unsafe.of_evar_map !evd) t in
+	(evd := Sigma.to_evar_map evm; t)
       end
       else
 	traverse_below nested envc t
@@ -1004,11 +1017,15 @@ let e_contextually byhead (occs,c) f env sigma t =
   in
   let t' = traverse None (env,c) t in
   if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs;
-  !evd, t'
+  Sigma.Unsafe.of_pair (t', !evd)
+  end }
 
 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)
+  let f' subst = { e_redfun = begin fun env sigma t ->
+    Sigma.here (f subst env (Sigma.to_evar_map sigma) t) sigma
+  end } in
+  let Sigma (c, _, _) = (e_contextually byhead occs f').e_redfun env (Sigma.Unsafe.of_evar_map sigma) t in
+  c
 
 (* linear bindings (following pretty-printer) of the value of name in c.
  * n is the number of the next occurrence of name.
@@ -1055,10 +1072,6 @@ 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 occurrences.
@@ -1112,7 +1125,7 @@ let cbv_norm_flags flags env sigma t =
 
 let cbv_beta = cbv_norm_flags beta empty_env
 let cbv_betaiota = cbv_norm_flags betaiota empty_env
-let cbv_betadeltaiota env sigma =  cbv_norm_flags betadeltaiota env sigma
+let cbv_betadeltaiota env sigma =  cbv_norm_flags all env sigma
 
 let compute = cbv_betadeltaiota
 
@@ -1131,13 +1144,15 @@ let abstract_scheme env (locc,a) (c, sigma) =
     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 pattern_occs loccs_trm = { e_redfun = begin fun env sigma c ->
+  let sigma = Sigma.to_evar_map sigma in
   let abstr_trm, sigma = List.fold_right (abstract_scheme env) loccs_trm (c,sigma) in
   try
     let _ = Typing.unsafe_type_of env sigma abstr_trm in
-      sigma, applist(abstr_trm, List.map snd loccs_trm)
+    Sigma.Unsafe.of_pair (applist(abstr_trm, List.map snd loccs_trm), sigma)
   with Type_errors.TypeError (env',t) ->
     raise (ReductionTacticError (InvalidAbstraction (env,sigma,abstr_trm,(env',t))))
+  end }
 
 (* Used in several tactics. *)
 
@@ -1163,14 +1178,15 @@ let reduce_to_ind_gen allow_product env sigma t =
     match kind_of_term (fst (decompose_app t)) with
       | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t l)
       | Prod (n,ty,t') ->
+	  let open Context.Rel.Declaration in
 	  if allow_product then
-	    elimrec (push_rel (n,None,ty) env) t' ((n,None,ty)::l)
+	    elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l)
 	  else
 	    errorlabstrm "" (str"Not an inductive definition.")
       | _ ->
 	  (* Last chance: we allow to bypass the Opaque flag (as it
 	     was partially the case between V5.10 and V8.1 *)
-	  let t' = whd_betadeltaiota env sigma t in
+	  let t' = whd_all env sigma t in
 	  match kind_of_term (fst (decompose_app t')) with
 	    | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t' l)
 	    | _ -> errorlabstrm "" (str"Not an inductive product.")
@@ -1241,7 +1257,8 @@ let reduce_to_ref_gen allow_product env sigma ref t =
     match kind_of_term c with
       | Prod (n,ty,t') ->
           if allow_product then
-	    elimrec (push_rel (n,None,t) env) t' ((n,None,ty)::l)
+	    let open Context.Rel.Declaration in
+	    elimrec (push_rel (LocalAssum (n,t)) env) t' ((LocalAssum (n,ty))::l)
           else
             error_cannot_recognize ref
       | _ ->
diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli
index 6a7248e1..f8dfe1ad 100644
--- a/pretyping/tacred.mli
+++ b/pretyping/tacred.mli
@@ -61,13 +61,12 @@ val unfoldn :
 val fold_commands : constr list ->  reduction_function
 
 (** Pattern *)
-val pattern_occs : (occurrences * constr) list -> env -> evar_map -> constr -> 
-   evar_map * constr
+val pattern_occs : (occurrences * constr) list -> e_reduction_function
 
 (** Rem: Lazy strategies are defined in Reduction *)
 
 (** Call by value strategy (uses Closures) *)
-val cbv_norm_flags : Closure.RedFlags.reds ->  reduction_function
+val cbv_norm_flags : CClosure.RedFlags.reds ->  reduction_function
   val cbv_beta : local_reduction_function
   val cbv_betaiota : local_reduction_function
   val cbv_betadeltaiota :  reduction_function
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index 3be98a1a..b8da6b68 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -12,11 +12,11 @@ open Globnames
 open Decl_kinds
 open Term
 open Vars
-open Context
 open Evd
 open Util
 open Typeclasses_errors
 open Libobject
+open Context.Rel.Declaration
 (*i*)
 
 let typeclasses_unique_solutions = ref false
@@ -25,7 +25,7 @@ let get_typeclasses_unique_solutions () = !typeclasses_unique_solutions
 
 open Goptions
 
-let set_typeclasses_unique_solutions =
+let _ =
   declare_bool_option
     { optsync  = true;
       optdepr  = false;
@@ -46,10 +46,10 @@ let set_typeclass_transparency gr local c = Hook.get set_typeclass_transparency
 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 get_solve_one_instance, solve_one_instance_hook = Hook.make ()
 
 let resolve_one_typeclass ?(unique=get_typeclasses_unique_solutions ()) env evm t =
-  !solve_instantiation_problem env evm t unique
+  Hook.get get_solve_one_instance env evm t unique
 
 type direction = Forward | Backward
 
@@ -59,13 +59,14 @@ type typeclass = {
   cl_impl : global_reference;
 
   (* Context in which the definitions are typed. Includes both typeclass parameters and superclasses. *)
-  cl_context : (global_reference * bool) option list * rel_context;
+  cl_context : (global_reference * bool) option list * Context.Rel.t;
 
   (* Context of definitions and properties on defs, will not be shared *)
-  cl_props : rel_context;
+  cl_props : Context.Rel.t;
 
   (* The method implementaions as projections. *)
-  cl_projs : (Name.t * (direction * int option) option * constant option) list;
+  cl_projs : (Name.t * (direction * Vernacexpr.hint_info_expr) option
+	      * constant option) list;
   
   cl_strict : bool;
 
@@ -76,10 +77,9 @@ type typeclasses = typeclass Refmap.t
 
 type instance = {
   is_class: global_reference;
-  is_pri: int option;
+  is_info: Vernacexpr.hint_info_expr;
   (* Sections where the instance should be redeclared,
-     -1 for discard, 0 for none, mutable to avoid redeclarations
-     when multiple rebuild_object happen. *)
+     -1 for discard, 0 for none. *)
   is_global: int;
   is_poly: bool;
   is_impl: global_reference;
@@ -89,15 +89,15 @@ type instances = (instance Refmap.t) Refmap.t
 
 let instance_impl is = is.is_impl
 
-let instance_priority is = is.is_pri
+let hint_priority is = is.is_info.Vernacexpr.hint_priority
 
-let new_instance cl pri glob poly impl =
+let new_instance cl info glob poly impl =
   let global =
     if glob then Lib.sections_depth ()
     else -1
   in
     { is_class = cl.cl_impl;
-      is_pri = pri ;
+      is_info = info ;
       is_global = global ;
       is_poly = poly;
       is_impl = impl }
@@ -127,7 +127,7 @@ let typeclass_univ_instance (cl,u') =
     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
+  let subst_ctx = Context.Rel.map (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'
 
@@ -150,7 +150,7 @@ let dest_class_arity env c =
 
 let class_of_constr c =
   try Some (dest_class_arity (Global.env ()) c)
-  with e when Errors.noncritical e -> None
+  with e when CErrors.noncritical e -> None
 
 let is_class_constr c = 
   try let gr, u = Universes.global_of_constr c in
@@ -181,9 +181,7 @@ let subst_class (subst,cl) =
   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
-    (fun (na, b, t) -> (na, Option.smartmap do_subst b, do_subst t))
-    ctx in
+  let do_subst_ctx = List.smartmap (map_constr do_subst) in
   let do_subst_context (grs,ctx) =
     List.smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs,
     do_subst_ctx ctx in
@@ -200,15 +198,19 @@ let discharge_class (_,cl) =
   let repl = Lib.replacement_context () in
   let rel_of_variable_context ctx = List.fold_right
     ( fun (n,_,b,t) (ctx', subst) ->
-	let decl = (Name n, Option.map (substn_vars 1 subst) b, substn_vars 1 subst t) in
+        let decl = match b with
+                   | None -> LocalAssum (Name n, substn_vars 1 subst t)
+		   | Some b -> LocalDef (Name n, substn_vars 1 subst b, substn_vars 1 subst t)
+	in
 	(decl :: ctx', n :: subst)
     ) ctx ([], []) in
   let discharge_rel_context subst n rel =
-    let rel = map_rel_context (Cooking.expmod_constr repl) rel in
+    let rel = Context.Rel.map (Cooking.expmod_constr repl) rel in
     let ctx, _ =
       List.fold_right
-	(fun (id, b, t) (ctx, k) ->
-	   (id, Option.smartmap (substn_vars k subst) b, substn_vars k subst t) :: ctx, succ k)
+	(fun decl (ctx, k) ->
+	   map_constr (substn_vars k subst) decl :: ctx, succ k
+	)
 	rel ([], n)
     in ctx
   in
@@ -218,15 +220,15 @@ let discharge_class (_,cl) =
       | ConstRef cst -> Lib.section_segment_of_constant cst
       | IndRef (ind,_) -> Lib.section_segment_of_mutual_inductive ind in
   let discharge_context ctx' subst (grs, ctx) =
-    let grs' = 
-      let newgrs = List.map (fun (_, _, t) -> 
-	match class_of_constr t with
-	| None -> None
-	| Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true))
-	ctx' 
+    let grs' =
+      let newgrs = List.map (fun decl ->
+			     match decl |> get_type |> class_of_constr with
+			     | None -> None
+			     | Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true))
+			    ctx'
       in
-	List.smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs
-	  @ newgrs
+      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
@@ -247,7 +249,7 @@ let rebuild_class cl =
   try 
     let cst = Tacred.evaluable_of_global_reference (Global.env ()) cl.cl_impl in
       set_typeclass_transparency cst false false; cl
-  with e when Errors.noncritical e -> cl
+  with e when CErrors.noncritical e -> cl
 
 let class_input : typeclass -> obj =
   declare_object
@@ -270,9 +272,11 @@ let check_instance env sigma c =
     let (evd, c) = resolve_one_typeclass env sigma
       (Retyping.get_type_of env sigma c) in
       not (Evd.has_undefined evd)
-  with e when Errors.noncritical e -> false
+  with e when CErrors.noncritical e -> false
+
+open Vernacexpr
 
-let build_subclasses ~check env sigma glob pri =
+let build_subclasses ~check env sigma glob { hint_priority = pri } =
   let _id = Nametab.basename_of_global glob in
   let _next_id = 
     let i = ref (-1) in 
@@ -287,7 +291,7 @@ let build_subclasses ~check env sigma glob pri =
       | None -> []
       | Some (rels, ((tc,u), args)) ->
 	let instapp = 
-	  Reductionops.whd_beta sigma (appvectc c (Termops.extended_rel_vect 0 rels)) 
+	  Reductionops.whd_beta sigma (appvectc c (Context.Rel.to_extended_vect 0 rels))
 	in
 	let projargs = Array.of_list (args @ [instapp]) in
 	let projs = List.map_filter 
@@ -295,24 +299,24 @@ let build_subclasses ~check env sigma glob pri =
 	   match b with 
 	   | None -> None
 	   | Some (Backward, _) -> None
-	   | Some (Forward, pri') ->
+	   | Some (Forward, info) ->
 	     let proj = Option.get proj 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 = 
-		   match pri, pri' with
+		 let newpri =
+		   match pri, info.hint_priority with
 		   | Some p, Some p' -> Some (p + p')
 		   | Some p, None -> Some (p + 1)
 		   | _, _ -> None
 		 in
-		   Some (ConstRef proj, pri, body)) tc.cl_projs 
+		   Some (ConstRef proj, { info with hint_priority = newpri }, body)) tc.cl_projs
 	in
-	let declare_proj hints (cref, pri, body) =
+	let declare_proj hints (cref, info, body) =
 	  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
+	    hints @ (path', info, body) :: rest
 	in List.fold_left declare_proj [] projs 
   in
   let term = Universes.constr_of_global_univ (glob,Univ.UContext.instance ctx) in
@@ -366,11 +370,11 @@ let is_local i = Int.equal i.is_global (-1)
 let add_instance check inst =
   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;
+    inst.is_info 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.from_env (Global.env ())) inst.is_impl inst.is_pri)
+       (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_info)
 
 let rebuild_instance (action, inst) =
   let () = match action with
@@ -402,26 +406,22 @@ let remove_instance i =
   Lib.add_anonymous_leaf (instance_input (RemoveInstance, i));
   remove_instance_hint i.is_impl
 
-let declare_instance pri local glob =
+let declare_instance info local glob =
   let ty = Global.type_of_global_unsafe glob in
+  let info = Option.default {hint_priority = None; hint_pattern = None} info in
     match class_of_constr ty with
     | 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); *)
-(* 	Auto.add_hints local [typeclasses_db]  *)
-(* 	(Auto.HintsCutEntry (PathSeq (PathStar (PathAtom PathAny), path))) *)
+      add_instance (new_instance tc info (not local) (Flags.use_polymorphic_flag ()) glob)
     | None -> ()
 
 let add_class cl =
   add_class cl;
   List.iter (fun (n, inst, body) ->
 	     match inst with
-	     | Some (Backward, pri) ->
+	     | Some (Backward, info) ->
 	       (match body with
-	       | None -> Errors.error "Non-definable projection can not be declared as a subinstance"
-	       | Some b -> declare_instance pri false (ConstRef b))
+	       | None -> CErrors.error "Non-definable projection can not be declared as a subinstance"
+	       | Some b -> declare_instance (Some info) false (ConstRef b))
 	     | _ -> ())
   cl.cl_projs
 
@@ -432,11 +432,7 @@ let add_class cl =
  *)
 
 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 lenpars = List.count is_local_assum (snd cl.cl_context) in
   let pars = fst (List.chop lenpars args) in
     match cl.cl_impl with
       | IndRef ind -> 
@@ -492,18 +488,21 @@ let is_instance = function
    Nota: we will only check the resolvability status of undefined evars.
  *)
 
-let resolvable = Store.field ()
+let resolvable = Proofview.Unsafe.typeclass_resolvable
 
 let set_resolvable s b =
-  Store.set s resolvable b
+  if b then Store.remove s resolvable
+  else Store.set s resolvable ()
 
 let is_resolvable evi =
   assert (match evi.evar_body with Evar_empty -> true | _ -> false);
-  Option.default true (Store.get evi.evar_extra resolvable)
+  Option.is_empty (Store.get evi.evar_extra resolvable)
 
 let mark_resolvability_undef b evi =
-  let t = Store.set evi.evar_extra resolvable b in
-  { evi with evar_extra = t }
+  if is_resolvable evi == (b : bool) then evi
+  else
+    let t = set_resolvable evi.evar_extra b in
+    { evi with evar_extra = t }
 
 let mark_resolvability b evi =
   assert (match evi.evar_body with Evar_empty -> true | _ -> false);
@@ -538,16 +537,16 @@ let has_typeclasses filter evd =
   in
   Evar.Map.exists check (Evd.undefined_map evd)
 
-let solve_instantiations_problem = ref (fun _ _ _ _ _ _ -> assert false)
+let get_solve_all_instances, solve_all_instances_hook = Hook.make ()
 
-let solve_problem env evd filter unique split fail =
-  !solve_instantiations_problem env evd filter unique split fail
+let solve_all_instances env evd filter unique split fail =
+  Hook.get get_solve_all_instances env evd filter unique split fail
 
 (** 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) ?(unique=get_typeclasses_unique_solutions ())
+let resolve_typeclasses ?(fast_path = true) ?(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
+  if fast_path && not (has_typeclasses filter evd) then evd
+  else solve_all_instances env evd filter unique split fail
diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli
index 9e018f61..620bc367 100644
--- a/pretyping/typeclasses.mli
+++ b/pretyping/typeclasses.mli
@@ -9,7 +9,6 @@
 open Names
 open Globnames
 open Term
-open Context
 open Evd
 open Environ
 
@@ -24,16 +23,16 @@ type typeclass = {
   (** Context in which the definitions are typed. Includes both typeclass parameters and superclasses.
      The boolean indicates if the typeclass argument is a direct superclass and the global reference
      gives a direct link to the class itself. *)
-  cl_context : (global_reference * bool) option list * rel_context;
+  cl_context : (global_reference * bool) option list * Context.Rel.t;
 
   (** Context of definitions and properties on defs, will not be shared *)
-  cl_props : rel_context;
+  cl_props : Context.Rel.t;
 
   (** The methods implementations of the typeclass as projections. 
       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.t * (direction * int option) option * constant option) list;
+  cl_projs : (Name.t * (direction * Vernacexpr.hint_info_expr) option * constant option) list;
 
   (** Whether we use matching or full unification during resolution *)
   cl_strict : bool; 
@@ -51,7 +50,7 @@ val all_instances : unit -> instance list
 
 val add_class : typeclass -> unit
 
-val new_instance : typeclass -> int option -> bool -> Decl_kinds.polymorphic -> 
+val new_instance : typeclass -> Vernacexpr.hint_info_expr -> bool -> Decl_kinds.polymorphic ->
   global_reference -> instance
 val add_instance : instance -> unit
 val remove_instance : instance -> unit
@@ -68,11 +67,11 @@ val dest_class_app : env -> constr -> typeclass puniverses * constr list
 val typeclass_univ_instance : typeclass puniverses -> typeclass puniverses
 
 (** Just return None if not a class *)
-val class_of_constr : constr -> (rel_context * (typeclass puniverses * constr list)) option
+val class_of_constr : constr -> (Context.Rel.t * (typeclass puniverses * constr list)) option
   
 val instance_impl : instance -> global_reference
 
-val instance_priority : instance -> int option
+val hint_priority : instance -> int option
 
 val is_class : global_reference -> bool
 val is_instance : global_reference -> bool
@@ -102,7 +101,7 @@ val mark_resolvable : evar_info -> evar_info
 val is_class_evar : evar_map -> evar_info -> bool
 val is_class_type : evar_map -> types -> bool
 
-val resolve_typeclasses : ?filter:evar_filter -> ?unique:bool -> 
+val resolve_typeclasses : ?fast_path:bool -> ?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
 
@@ -114,21 +113,22 @@ val classes_transparent_state : unit -> transparent_state
 
 val add_instance_hint_hook : 
   (global_reference_or_constr -> global_reference list ->
-   bool (* local? *) -> int option -> Decl_kinds.polymorphic -> unit) Hook.t
+   bool (* local? *) -> Vernacexpr.hint_info_expr -> 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
+  bool -> Vernacexpr.hint_info_expr -> Decl_kinds.polymorphic -> unit
 val remove_instance_hint : global_reference -> unit
 
-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 solve_all_instances_hook : (env -> evar_map -> evar_filter -> bool -> bool -> bool -> evar_map) Hook.t
+val solve_one_instance_hook : (env -> evar_map -> types -> bool -> open_constr) Hook.t
 
-val declare_instance : int option -> bool -> global_reference -> unit
+val declare_instance : Vernacexpr.hint_info_expr option -> bool -> global_reference -> unit
 
 
 (** Build the subinstances hints for a given typeclass object.
     check tells if we should check for existence of the 
     subinstances and add only the missing ones. *)
 
-val build_subclasses : check:bool -> env -> evar_map -> global_reference -> int option (* priority *) ->
-  (global_reference list * int option * constr) list
+val build_subclasses : check:bool -> env -> evar_map -> global_reference ->
+		       Vernacexpr.hint_info_expr ->
+		       (global_reference list * Vernacexpr.hint_info_expr * constr) list
diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml
index a0f63198..b1dfb19a 100644
--- a/pretyping/typeclasses_errors.ml
+++ b/pretyping/typeclasses_errors.ml
@@ -9,7 +9,6 @@
 (*i*)
 open Names
 open Term
-open Context
 open Environ
 open Constrexpr
 open Globnames
@@ -20,7 +19,7 @@ type contexts = Parameters | Properties
 type typeclass_error =
     | NotAClass of constr
     | UnboundMethod of global_reference * Id.t Loc.located (* Class name, method *)
-    | MismatchedContextInstance of contexts * constr_expr list * rel_context (* found, expected *)
+    | MismatchedContextInstance of contexts * constr_expr list * Context.Rel.t (* found, expected *)
 
 exception TypeClassError of env * typeclass_error
 
diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli
index 7facb06f..ee76f638 100644
--- a/pretyping/typeclasses_errors.mli
+++ b/pretyping/typeclasses_errors.mli
@@ -9,7 +9,6 @@
 open Loc
 open Names
 open Term
-open Context
 open Environ
 open Constrexpr
 open Globnames
@@ -19,7 +18,7 @@ type contexts = Parameters | Properties
 type typeclass_error =
   | NotAClass of constr
   | UnboundMethod of global_reference * Id.t located (** Class name, method *)
-  | MismatchedContextInstance of contexts * constr_expr list * rel_context (** found, expected *)
+  | MismatchedContextInstance of contexts * constr_expr list * Context.Rel.t (** found, expected *)
 
 exception TypeClassError of env * typeclass_error
 
@@ -27,5 +26,5 @@ val not_a_class : env -> constr -> 'a
 
 val unbound_method : env -> global_reference -> Id.t located -> 'a
 
-val mismatched_ctx_inst : env -> contexts -> constr_expr list -> rel_context -> 'a
+val mismatched_ctx_inst : env -> contexts -> constr_expr list -> Context.Rel.t -> 'a
 
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index eb16628b..9e9997f7 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Term
 open Vars
@@ -18,6 +18,7 @@ open Inductive
 open Inductiveops
 open Typeops
 open Arguments_renaming
+open Context.Rel.Declaration
 
 let meta_type evd mv =
   let ty =
@@ -35,10 +36,10 @@ let inductive_type_knowing_parameters env (ind,u) jl =
   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
+  match kind_of_term (whd_all 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 env !evdref ev in
+        let (evd,s) = Evardefine.define_evar_as_sort env !evdref ev in
         evdref := evd; { utj_val = j.uj_val; utj_type = s }
     | _ -> error_not_type env j
 
@@ -53,14 +54,14 @@ let e_judge_of_apply env evdref funj argjv =
       { uj_val  = mkApp (j_val funj, Array.map j_val argjv);
         uj_type = typ }
   | hj::restjl ->
-      match kind_of_term (whd_betadeltaiota env !evdref typ) with
+      match kind_of_term (whd_all env !evdref typ) with
       | Prod (_,c1,c2) ->
 	 if Evarconv.e_cumul env evdref hj.uj_type c1 then
 	   apply_rec (n+1) (subst1 hj.uj_val c2) restjl
 	 else
 	   error_cant_apply_bad_type env (n,c1, hj.uj_type) funj argjv
       | Evar ev ->
-	  let (evd',t) = Evarutil.define_evar_as_product !evdref ev in
+	  let (evd',t) = Evardefine.define_evar_as_product !evdref ev in
           evdref := evd';
           let (_,_,c2) = destProd t in
 	  apply_rec (n+1) (subst1 hj.uj_val c2) restjl
@@ -86,18 +87,18 @@ let e_is_correct_arity env evdref c pj ind specif params =
   let allowed_sorts = elim_sorts specif in
   let error () = error_elim_arity env ind allowed_sorts c pj None in
   let rec srec env pt ar =
-    let pt' = whd_betadeltaiota env !evdref pt in
+    let pt' = whd_all env !evdref pt in
     match kind_of_term pt', ar with
-    | Prod (na1,a1,t), (_,None,a1')::ar' ->
+    | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' ->
         if not (Evarconv.e_cumul env evdref a1 a1') then error ();
-        srec (push_rel (na1,None,a1) env) t ar'
+        srec (push_rel (LocalAssum (na1,a1)) env) t ar'
     | Sort s, [] ->
         if not (Sorts.List.mem (Sorts.family s) allowed_sorts)
         then error ()
     | Evar (ev,_), [] ->
         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' ->
+    | _, (LocalDef _ as d)::ar' ->
         srec (push_rel d env) (lift 1 pt') ar'
     | _ ->
         error ()
@@ -109,23 +110,32 @@ let e_type_case_branches env evdref (ind,largs) pj c =
   let nparams = inductive_params specif 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 () = 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 in
-  let ty =
-    whd_betaiota !evdref (Reduction.betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) in
-  (lc, ty, univ)
+  let n = (snd specif).Declarations.mind_nrealdecls in
+  let ty = whd_betaiota !evdref (lambda_applist_assum (n+1) p (realargs@[c])) in
+  (lc, ty)
 
 let e_judge_of_case env evdref ci pj cj lfj =
   let indspec =
     try find_mrectype env !evdref 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) = e_type_case_branches env evdref indspec pj cj.uj_val in
+  let (bty,rslty) = e_type_case_branches env evdref indspec pj cj.uj_val in
   e_check_branch_types env evdref (fst indspec) cj (lfj,bty);
   { uj_val  = mkCase (ci, pj.uj_val, cj.uj_val, Array.map j_val lfj);
     uj_type = rslty }
 
+let check_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 (Evarconv.e_cumul env evdref (vdefj.(i)).uj_type
+		  (lift lt lar.(i))) then
+          Pretype_errors.error_ill_typed_rec_body_loc loc env !evdref
+            i lna vdefj lar
+      done
+
 (* 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
@@ -230,14 +240,14 @@ let rec execute env evdref cstr =
     | Lambda (name,c1,c2) ->
         let j = execute env evdref c1 in
 	let var = e_type_judgment env evdref j in
-	let env1 = push_rel (name,None,var.utj_val) env in
+	let env1 = push_rel (LocalAssum (name, var.utj_val)) env in
         let j' = execute env1 evdref c2 in
         judge_of_abstraction env1 name var j'
 
     | Prod (name,c1,c2) ->
         let j = execute env evdref c1 in
         let varj = e_type_judgment env evdref j in
-	let env1 = push_rel (name,None,varj.utj_val) env in
+	let env1 = push_rel (LocalAssum (name, varj.utj_val)) env in
         let j' = execute env1 evdref c2 in
         let varj' = e_type_judgment env1 evdref j' in
 	judge_of_product env name varj varj'
@@ -247,7 +257,7 @@ let rec execute env evdref cstr =
         let j2 = execute env evdref c2 in
         let j2 = e_type_judgment env evdref 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 env1 = push_rel (LocalDef (name, j1.uj_val, j2.utj_val)) env in
         let j3 = execute env1 evdref c3 in
         judge_of_letin env name j1 j2 j3
 
@@ -263,12 +273,12 @@ and execute_recdef env evdref (names,lar,vdef) =
   let env1 = push_rec_types (names,lara,vdef) env in
   let vdefj = execute_array env1 evdref vdef in
   let vdefv = Array.map j_val vdefj in
-  let _ = type_fixpoint env1 names lara vdefj in
+  let _ = check_type_fixpoint Loc.ghost env1 evdref names lara vdefj in
   (names,lara,vdefv)
 
 and execute_array env evdref = Array.map (execute env evdref)
 
-let check env evdref c t =
+let e_check env evdref c t =
   let env = enrich_env env evdref in
   let j = execute env evdref c in
   if not (Evarconv.e_cumul env evdref j.uj_type t) then
@@ -284,7 +294,7 @@ let unsafe_type_of env evd c =
 
 (* Sort of a type *)
 
-let sort_of env evdref c =
+let e_sort_of env evdref c =
   let env = enrich_env env evdref in
   let j = execute env evdref c in
   let a = e_type_judgment env evdref j in
@@ -311,10 +321,10 @@ let e_type_of ?(refresh=false) env evdref c =
       c
     else j.uj_type
 
-let solve_evars env evdref c =
+let e_solve_evars env evdref c =
   let env = enrich_env env evdref in
   let c = (execute env evdref c).uj_val in
   (* side-effect on evdref *)
   nf_evar !evdref c
 
-let _ = Evarconv.set_solve_evars solve_evars
+let _ = Evarconv.set_solve_evars e_solve_evars
diff --git a/pretyping/typing.mli b/pretyping/typing.mli
index dafd7523..04e5e40b 100644
--- a/pretyping/typing.mli
+++ b/pretyping/typing.mli
@@ -24,18 +24,23 @@ val type_of : ?refresh:bool -> env -> evar_map -> constr -> evar_map * types
 val e_type_of : ?refresh:bool -> env -> evar_map ref -> constr -> types
 
 (** Typecheck a type and return its sort *)
-val sort_of : env -> evar_map ref -> types -> sorts
+val e_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 ref -> constr -> types -> unit
+val e_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 ref -> constr -> constr
+val e_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 -> pinductive -> constr -> constr ->
   unit
+
+(** Raise an error message if bodies have types not unifiable with the
+    expected ones *)
+val check_type_fixpoint : Loc.t -> env -> evar_map ref ->
+  Names.Name.t array -> types array -> unsafe_judgment array -> unit
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index f97f6fbc..25931869 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Pp
 open Util
 open Names
@@ -19,6 +19,7 @@ open Evd
 open Reduction
 open Reductionops
 open Evarutil
+open Evardefine
 open Evarsolve
 open Pretype_errors
 open Retyping
@@ -27,6 +28,8 @@ open Recordops
 open Locus
 open Locusops
 open Find_subterm
+open Sigma.Notations
+open Context.Named.Declaration
 
 let keyed_unification = ref (false)
 let _ = Goptions.declare_bool_option {
@@ -57,7 +60,7 @@ let occur_meta_or_undefined_evar evd c =
         | Evar_defined c ->
             occrec c; Array.iter occrec args
         | Evar_empty -> raise Occur)
-    | _ -> iter_constr occrec c
+    | _ -> Constr.iter occrec c
   in try occrec c; false with Occur | Not_found -> true
 
 let occur_meta_evd sigma mv c =
@@ -66,7 +69,7 @@ let occur_meta_evd sigma mv c =
     let c = whd_evar sigma (whd_meta sigma c) in
     match kind_of_term c with
     | Meta mv' when Int.equal mv mv' -> raise Occur
-    | _ -> iter_constr occrec c
+    | _ -> Constr.iter 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,
@@ -74,7 +77,10 @@ let occur_meta_evd sigma mv c =
 
 let abstract_scheme env evd c l lname_typ =
   List.fold_left2
-    (fun (t,evd) (locc,a) (na,_,ta) ->
+    (fun (t,evd) (locc,a) decl ->
+       let open Context.Rel.Declaration in
+       let na = get_name decl in
+       let ta = get_type decl in
        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...
@@ -107,7 +113,9 @@ let set_occurrences_of_last_arg 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 env evd typ in
+  let evd = Sigma.Unsafe.of_evar_map evd in
+  let Sigma (ev, evd, _) = new_evar env evd typ in
+  let evd = Sigma.to_evar_map evd in
   let evd,ev' = evar_absorb_arguments env evd (destEvar ev) l in
   let n = List.length l in
   let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in
@@ -143,7 +151,7 @@ let rec subst_meta_instances bl 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
+    | _ -> Constr.map (subst_meta_instances bl) c
 
 (** [env] should be the context in which the metas live *)
 
@@ -161,7 +169,7 @@ let pose_all_metas_as_evars env evd t =
         evdref := meta_assign mv (ev,(Conv,TypeNotProcessed)) !evdref;
         ev)
   | _ ->
-      map_constr aux t in
+      Constr.map aux t in
   let c = aux t in
   (* side-effect *)
   (!evdref, c)
@@ -356,6 +364,22 @@ let set_no_delta_flags flags = {
   resolve_evars = flags.resolve_evars
 }
 
+(* For the first phase of keyed unification, restrict
+  to conversion (including beta-iota) only on closed terms *)
+let set_no_delta_open_core_flags flags = { flags with
+  modulo_delta = empty_transparent_state;
+  modulo_betaiota = false;
+}
+
+let set_no_delta_open_flags flags = {
+  core_unify_flags = set_no_delta_open_core_flags flags.core_unify_flags;
+  merge_unify_flags = set_no_delta_open_core_flags flags.merge_unify_flags;
+  subterm_unify_flags = set_no_delta_open_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" extended *)
@@ -436,7 +460,7 @@ let use_metas_pattern_unification flags nb l =
      Array.for_all (fun c -> isRel c && destRel c <= nb) l
 
 type key = 
-  | IsKey of Closure.table_key
+  | IsKey of CClosure.table_key
   | IsProj of projection * constr
 
 let expand_table_key env = function
@@ -455,8 +479,8 @@ let unfold_projection env p stk =
 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 [])))
+    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
 
@@ -481,7 +505,8 @@ let key_of env b flags f =
       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) ->
+    || (is_transparent env (ConstKey (Projection.constant p)) &&
+       (Cpred.mem (Projection.constant p) (snd flags.modulo_delta))) ->
     Some (IsProj (p, c))
   | _ -> None
   
@@ -547,7 +572,8 @@ let constr_cmp pb sigma flags t u =
     else sigma, b
     
 let do_reduce ts (env, nb) sigma c =
-  Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma Cst_stack.empty (c, Stack.empty)))
+  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
@@ -556,6 +582,19 @@ let isAllowedEvar flags c = match kind_of_term c with
   | Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars)
   | _ -> false
 
+
+let subst_defined_metas_evars (bl,el) c =
+  let rec substrec c = match kind_of_term c with
+    | 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 -> Constr.map substrec c)
+    | _ -> Constr.map substrec c
+  in try Some (substrec c) with Not_found -> None
+
 let check_compatibility env pbty flags (sigma,metasubst,evarsubst) tyM tyN =
   match subst_defined_metas_evars (metasubst,[]) tyM with
   | None -> sigma
@@ -592,7 +631,7 @@ let is_eta_constructor_app env ts f l1 term =
   | 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 &&
+      | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite == Decl_kinds.BiFinite &&
           Array.length projs == Array.length l1 - mib.Declarations.mind_nparams ->
 	(** Check that the other term is neutral *)
 	is_neutral env ts term
@@ -619,7 +658,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb
     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)
+	Feedback.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 ->
@@ -704,7 +743,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb
 		 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 ->
+	     with e when CErrors.noncritical e ->
                error_cannot_unify curenv sigma (m,n))
 
 	| Lambda (na,t1,c1), Lambda (_,t2,c2) ->
@@ -1016,12 +1055,14 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb
     else error_cannot_unify (fst curenvnb) sigma (cM,cN)
   in
     
-  if !debug_unification then msg_debug (str "Starting unification");
+  if !debug_unification then Feedback.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
+    if subterm_restriction opt flags ||
+      occur_meta_or_undefined_evar sigma m || occur_meta_or_undefined_evar sigma n
+    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
@@ -1037,11 +1078,12 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb
     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");
+    if !debug_unification then Feedback.msg_debug (str "Leaving unification with success");
     a
   with e ->
-    if !debug_unification then msg_debug (str "Leaving unification with failure");
-    raise e
+    let e = CErrors.push e in
+    if !debug_unification then Feedback.msg_debug (str "Leaving unification with failure");
+    iraise e
 
 
 let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env
@@ -1050,7 +1092,7 @@ let left = true
 let right = false
 
 let rec unify_with_eta keptside flags env sigma c1 c2 =
-(* Question: try whd_betadeltaiota on ci if not two lambdas? *)
+(* Question: try whd_all on ci if not two lambdas? *)
   match kind_of_term c1, kind_of_term c2 with
   | (Lambda (na,t1,c1'), Lambda (_,t2,c2')) ->
     let env' = push_rel_assum (na,t1) env in
@@ -1098,11 +1140,11 @@ let merge_instances env sigma flags st1 st2 c1 c2 =
       else (right, st2, res)
   | (IsSuperType,IsSubType) ->
     (try (left, IsSubType, unify_0 env sigma CUMUL flags c2 c1)
-     with e when Errors.noncritical e ->
+     with e when CErrors.noncritical e ->
        (right, IsSubType, unify_0 env sigma CUMUL flags c1 c2))
   | (IsSubType,IsSuperType) ->
     (try (left, IsSuperType, unify_0 env sigma CUMUL flags c1 c2)
-     with e when Errors.noncritical e ->
+     with e when CErrors.noncritical e ->
        (right, IsSuperType, unify_0 env sigma CUMUL flags c2 c1))
     
 (* Unification
@@ -1154,31 +1196,31 @@ let merge_instances env sigma flags st1 st2 c1 c2 =
  * close it off.  But this might not always work,
  * since other metavars might also need to be resolved. *)
 
-let applyHead env evd n c  =
-  let rec apprec n c cty evd =
+let applyHead env (type r) (evd : r Sigma.t) n c =
+  let rec apprec : type s. _ -> _ -> _ -> (r, s) Sigma.le -> s Sigma.t -> (constr, r) Sigma.sigma =
+    fun n c cty p evd ->
     if Int.equal n 0 then
-      (evd, c)
+      Sigma (c, evd, p)
     else
-      match kind_of_term (whd_betadeltaiota env evd cty) with
+      match kind_of_term (whd_all env (Sigma.to_evar_map evd) cty) with
       | Prod (_,c1,c2) ->
-        let (evd',evar) =
-	  Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in
-	  apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd'
+        let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in
+	  apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd'
       | _ -> error "Apply_Head_Then"
   in
-    apprec n c (Typing.unsafe_type_of env evd c) evd
-    
+    apprec n c (Typing.unsafe_type_of env (Sigma.to_evar_map evd) c) Sigma.refl evd
+
 let is_mimick_head ts f =
   match kind_of_term f with
-  | Const (c,u) -> not (Closure.is_transparent_constant ts c)
-  | Var id -> not (Closure.is_transparent_variable ts id)
+  | Const (c,u) -> not (CClosure.is_transparent_constant ts c)
+  | Var id -> not (CClosure.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 Loc.ghost env evd j tycon in
-  let evd' = Evarconv.consider_remaining_unif_problems env evd' in
+  let evd' = Evarconv.solve_unif_constraints_with_heuristics env evd' in
   let evd' = Evd.map_metas_fvalue (nf_evar evd') evd' in
     (evd',j'.uj_val)
 
@@ -1228,7 +1270,11 @@ let solve_simple_evar_eqn ts env evd ev rhs =
   | UnifFailure (evd,reason) ->
       error_cannot_unify env evd ~reason (mkEvar ev,rhs);
   | Success evd ->
-      Evarconv.consider_remaining_unif_problems env evd
+     if Flags.version_less_or_equal Flags.V8_5 then
+       (* We used to force solving unrelated problems at arbitrary times *)
+       Evarconv.solve_unif_constraints_with_heuristics env evd
+     else (* solve_simple_eqn calls reconsider_unif_constraints itself *)
+       evd
 
 (* [w_merge env sigma b metas evars] merges common instances in metas
    or in evars, possibly generating new unification problems; if [b]
@@ -1255,7 +1301,6 @@ 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
-		(* let evd' = Evarconv.consider_remaining_unif_problems env evd' in *)
 		  w_merge_rec evd' metas evars eqns
 	      else
 		let evd' = 
@@ -1303,7 +1348,7 @@ let w_merge env with_types flags (evd,metas,evars) =
     	  else
             let evd' =
               if occur_meta_evd evd mv c then
-                if isMetaOf mv (whd_betadeltaiota env evd c) then evd
+                if isMetaOf mv (whd_all env evd c) then evd
                 else error_cannot_unify env evd (mkMeta mv,c)
               else
 	        meta_assign mv (c,(status,TypeProcessed)) evd in
@@ -1313,7 +1358,7 @@ let w_merge env with_types flags (evd,metas,evars) =
 	let rec process_eqns failures = function
 	  | (mv,status,c)::eqns ->
               (match (try Inl (unify_type env evd flags mv status c)
-		      with e when Errors.noncritical e -> Inr e)
+		      with e when CErrors.noncritical e -> Inr e)
 	       with 
 	       | Inr e -> process_eqns (((mv,status,c),e)::failures) eqns
 	       | Inl (evd,metas,evars) ->
@@ -1327,7 +1372,9 @@ let w_merge env with_types flags (evd,metas,evars) =
   and mimick_undefined_evar evd flags hdc nargs sp =
     let ev = Evd.find_undefined evd sp in
     let sp_env = Global.env_of_context ev.evar_hyps in
-    let (evd', c) = applyHead sp_env evd nargs hdc in
+    let evd = Sigma.Unsafe.of_evar_map evd in
+    let Sigma (c, evd', _) = applyHead sp_env evd nargs hdc in
+    let evd' = Sigma.to_evar_map evd' in
     let (evd'',mc,ec) =
       unify_0 sp_env evd' CUMUL flags
         (get_type_of sp_env evd' c) ev.evar_concl in
@@ -1345,10 +1392,11 @@ let w_merge env with_types flags (evd,metas,evars) =
     in w_merge_rec evd [] [] eqns
   in
   let res =  (* merge constraints *)
-    w_merge_rec evd (order_metas metas) (List.rev evars) []
+    w_merge_rec evd (order_metas metas)
+                (* Assign evars in the order of assignments during unification *)
+                (List.rev evars) []
   in
-    if with_types then check_types res
-    else res
+  if with_types then check_types res else res
 
 let w_unify_meta_types env ?(flags=default_unify_flags ()) evd =
   let metas,evd = retract_coercible_metas evd in
@@ -1406,7 +1454,7 @@ let w_typed_unify_array env evd flags f1 l1 f2 l2 =
   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))
+                          (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
@@ -1430,15 +1478,16 @@ let indirectly_dependent c d decls =
        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
+    List.exists (fun d' -> dependent_in_decl (mkVar (get_id d')) d) decls
 
 let indirect_dependency d decls =
-  pi1 (List.hd (List.filter (fun (id,_,_) -> dependent_in_decl (mkVar id) d) decls))
+  decls  |>  List.filter (fun d' -> dependent_in_decl (mkVar (get_id d')) d)  |>  List.hd  |>  get_id
 
 let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) =
+  let current_sigma = Sigma.to_evar_map current_sigma in
   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)
+  Sigma.Unsafe.of_pair (subst_univs_constr subst (nf_evar sigma c), sigma)
 
 let default_matching_core_flags sigma =
   let ts = Names.full_transparent_state in {
@@ -1450,9 +1499,7 @@ let default_matching_core_flags sigma =
   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;
+  frozen_evars = Evar.Map.domain (Evd.undefined_map sigma);
   restrict_conv_on_strict_subterms = false;
   modulo_betaiota = false;
   modulo_eta = false;
@@ -1514,11 +1561,12 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) =
     | 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
+    | e when CErrors.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 (evd,c1,x), Some (_,c2,_) ->
+      let (evd,b) = infer_conv ~pb:CONV env evd c1 c2 in
+      if b then Some (evd, c1, x) else raise (NotUnifiable None)
     | Some _, None -> c1
     | None, Some _ -> c2
     | None, None -> None in
@@ -1543,7 +1591,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
     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
+    if mem_named_context_val x (named_context_val env) then
       errorlabstrm "Unification.make_abstraction_core"
         (str "The variable " ++ Nameops.pr_id x ++ str " is already declared.")
     else
@@ -1551,21 +1599,15 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
   in
   let likefirst = clause_with_generic_occurrences occs in
   let mkvarid () = mkVar id in
-  let compute_dependency _ (hyp,_,_ as d) (sign,depdecls) =
+  let compute_dependency _ d (sign,depdecls) =
+    let hyp = get_id d in
     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)
+        (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
+        if Context.Named.Declaration.equal d newdecl
            && not (indirectly_dependent c d depdecls)
         then
           if check_occs && not (in_every_hyp occs)
@@ -1588,8 +1630,12 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
           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)
+      if List.is_empty depdecls then None else Some (get_id (List.last depdecls)) in
+    let res = match out test with
+    | None -> None
+    | Some (sigma, c) -> Some (Sigma.Unsafe.of_pair (c, sigma))
+    in
+    (id,sign,depdecls,lastlhyp,ccl,res)
   with
     SubtermUnificationError e ->
       raise (PretypeError (env,sigma,CannotUnifyOccurrences e))
@@ -1611,12 +1657,13 @@ 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 =
+type 'r abstraction_result =
   Names.Id.t * named_context_val *
-    Context.named_declaration list * Names.Id.t option *
-    types * (Evd.evar_map * constr) option
+    Context.Named.Declaration.t list * Names.Id.t option *
+    types * (constr, 'r) Sigma.sigma option
 
 let make_abstraction env evd ccl abs =
+  let evd = Sigma.to_evar_map evd in
   match abs with
   | AbstractPattern (from_prefix,check,name,c,occs,check_occs) ->
       make_abstraction_core name
@@ -1791,17 +1838,25 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t =
         let allow_K = flags.allow_K_in_toplevel_higher_order_unification in
         let flags =
           if occur_meta_or_existential op || !keyed_unification then
+	    (* This is up to delta for subterms w/o metas ... *)
             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
+          set_no_delta_flags flags in
+	let t' = (strip_outer_cast op,t) 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)
+  	    if is_keyed_unification () then
+    	      try (* First try finding a subterm w/o conversion on open terms *)
+	        let flags = set_no_delta_open_flags flags in
+		w_unify_to_subterm env evd ~flags t'
+	      with e ->
+		(* If this fails, try with full conversion *)
+		w_unify_to_subterm env evd ~flags t'
+	    else w_unify_to_subterm env evd ~flags t'
 	  with PretypeError (env,_,NoOccurrenceFound _) when
               allow_K ||
                 (* w_unify_to_subterm does not go through evars, so
@@ -1828,21 +1883,14 @@ let secondOrderAbstraction env evd flags typ (p, oplist) =
     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) *)
+          (evd',[p,pred,(Conv,TypeProcessed)],[])
 
 let secondOrderDependentAbstraction env evd flags typ (p, oplist) =
   let typp = Typing.meta_type evd p in
   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)],[])
+          (evd,[p,pred,(Conv,TypeProcessed)],[])
+
 
 let secondOrderAbstractionAlgo dep =
   if dep then secondOrderDependentAbstraction else secondOrderAbstraction
diff --git a/pretyping/unification.mli b/pretyping/unification.mli
index d5d5caf9..0ad882a9 100644
--- a/pretyping/unification.mli
+++ b/pretyping/unification.mli
@@ -75,15 +75,15 @@ type abstraction_request =
 | 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
+  env -> 'r Sigma.t -> pending_constr -> (constr, 'r) Sigma.sigma
 
-type abstraction_result =
+type 'r abstraction_result =
   Names.Id.t * named_context_val *
-    Context.named_declaration list * Names.Id.t option *
-    types * (Evd.evar_map * constr) option
+    Context.Named.Declaration.t list * Names.Id.t option *
+    types * (constr, 'r) Sigma.sigma option
 
-val make_abstraction : env -> Evd.evar_map -> constr ->
-  abstraction_request -> abstraction_result
+val make_abstraction : env -> 'r Sigma.t -> constr ->
+  abstraction_request -> 'r abstraction_result
 
 val pose_all_metas_as_evars : env -> evar_map -> constr -> evar_map * constr
 
diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index 7d86fad9..e281f22d 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -15,6 +15,7 @@ open Environ
 open Inductive
 open Reduction
 open Vm
+open Context.Rel.Declaration
 
 (*******************************************)
 (* Calcul de la forme normal d'un terme    *)
@@ -23,7 +24,7 @@ open Vm
 let crazy_type =  mkSet
 
 let decompose_prod env t =
-  let (name,dom,codom as res) = destProd (whd_betadeltaiota env t) in
+  let (name,dom,codom as res) = destProd (whd_all env t) in
   match name with
   | Anonymous -> (Name (Id.of_string "x"), dom, codom)
   | Name _ -> res
@@ -46,12 +47,10 @@ let invert_tag cst tag reloc_tbl =
              (* Argggg, ces constructeurs de ... qui commencent a 1*)
 
 let find_rectype_a env c =
-  let (t, l) =
-    let t = whd_betadeltaiota env c in
-    try destApp t with DestKO -> (t,[||]) in
+  let (t, l) = decompose_appvect (whd_all env c) in
   match kind_of_term t with
   | Ind ind -> (ind, l)
-  | _ -> raise Not_found
+  | _ -> assert false
 
 (* Instantiate inductives and parameters in constructor type *)
 
@@ -59,11 +58,11 @@ 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 ndecls = Context.rel_context_length mib.mind_params_ctxt in
+  let ndecls = Context.Rel.length mib.mind_params_ctxt in
   if Int.equal ndecls 0 then ctyp
   else
     let _,ctyp = decompose_prod_n_assum ndecls ctyp in
-    substl (List.rev (Termops.adjust_subst_to_rel_context mib.mind_params_ctxt (Array.to_list params)))
+    substl (List.rev (adjust_subst_to_rel_context mib.mind_params_ctxt (Array.to_list params)))
       ctyp
 
 
@@ -140,7 +139,7 @@ and nf_whd env whd typ =
       let dom = nf_vtype env (dom p) 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
+      let codom = nf_vtype (push_rel (LocalAssum (name,dom)) env) vc  in
       mkProd(name,dom,codom)
   | Vfun f -> nf_fun env f typ
   | Vfix(f,None) -> nf_fix env f
@@ -208,11 +207,12 @@ and constr_type_of_idkey env (idkey : Vars.id_key) stk =
      in
      nf_univ_args ~nb_univs mk env stk
    | VarKey id ->
-      let (_,_,ty) = lookup_named id env in
+      let open Context.Named.Declaration in
+      let ty = get_type (lookup_named id env) in
       nf_stk env (mkVar id) ty stk
   | RelKey i ->
       let n = (nb_rel env - i) in
-      let (_,_,ty) = lookup_rel n env in
+      let ty = get_type (lookup_rel n env) in
       nf_stk env (mkRel n) (lift n ty) stk
 
 and nf_stk ?from:(from=0) env c t stk  =
@@ -238,7 +238,7 @@ and nf_stk ?from:(from=0) env c t stk  =
       let params,realargs = Util.Array.chop nparams allargs in
       let pT =
 	hnf_prod_applist env (type_of_ind env (ind,u)) (Array.to_list params) in
-      let pT = whd_betadeltaiota env pT in
+      let pT = whd_all env 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 u params dep p in
@@ -266,7 +266,7 @@ and nf_predicate env ind mip params v pT =
       let vb = body_of_vfun k f 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
+	nf_predicate (push_rel (LocalAssum (name,dom)) env) ind mip params vb codom in
       dep, mkLambda(name,dom,body)
   | Vfun f, _ ->
       let k = nb_rel env in
@@ -276,7 +276,7 @@ and nf_predicate env ind mip params v pT =
       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_vtype (push_rel (name,None,dom) env) vb in
+      let body = nf_vtype (push_rel (LocalAssum (name,dom)) env) vb in
       true, mkLambda(name,dom,body)
   | _, _ -> false, nf_val env v crazy_type
 
@@ -309,10 +309,10 @@ and nf_fun env f typ =
     try decompose_prod env typ
     with DestKO ->
       (* 27/2/13: Turned this into an anomaly *)
-      Errors.anomaly
+      CErrors.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
+  let body = nf_val (push_rel (LocalAssum (name,dom)) env) vb codom in
   mkLambda(name,dom,body)
 
 and nf_fix env f =
diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli
index bdc6c1db..58f5b14e 100644
--- a/pretyping/vnorm.mli
+++ b/pretyping/vnorm.mli
@@ -8,7 +8,6 @@
 
 open Term
 open Environ
-open Evd
 
 (** {6 Reduction functions } *)
 val cbv_vm : env -> constr -> types -> constr
diff --git a/printing/genprint.ml b/printing/genprint.ml
index d4f792b7..0ec35e07 100644
--- a/printing/genprint.ml
+++ b/printing/genprint.ml
@@ -19,8 +19,9 @@ 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 default wit = match wit with
+  | ExtraArg tag ->
+    let name = ArgT.repr tag in
     let printer = {
       raw = (fun _ -> str "<genarg:" ++ str name ++ str ">");
       glb = (fun _ -> str "<genarg:" ++ str name ++ str ">");
@@ -40,6 +41,6 @@ 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
+let generic_raw_print (GenArg (Rawwit w, v)) = raw_print w v
+let generic_glb_print (GenArg (Glbwit w, v)) = glb_print w v
+let generic_top_print (GenArg (Topwit w, v)) = top_print w v
diff --git a/printing/miscprint.ml b/printing/miscprint.ml
index 22db3d0b..7b2c5695 100644
--- a/printing/miscprint.ml
+++ b/printing/miscprint.ml
@@ -28,14 +28,14 @@ and pr_intro_pattern_action prc = function
   | 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
+  | 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] ->
+  | IntroAndPattern pl ->
       str "(" ++ hv 0 (prlist_with_sep pr_comma (pr_intro_pattern prc) pl) ++ str ")"
-  | pll ->
+  | IntroOrPattern pll ->
       str "[" ++
       hv 0 (prlist_with_sep pr_bar (prlist_with_sep spc (pr_intro_pattern prc)) pll)
       ++ str "]"
diff --git a/printing/ppannotation.ml b/printing/ppannotation.ml
index df7f925b..511f9356 100644
--- a/printing/ppannotation.ml
+++ b/printing/ppannotation.ml
@@ -20,7 +20,6 @@ type t =
   | 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
@@ -32,7 +31,6 @@ let tag_of_annotation = function
   | 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 =
diff --git a/printing/ppannotation.mli b/printing/ppannotation.mli
index 84724053..a0fef1a7 100644
--- a/printing/ppannotation.mli
+++ b/printing/ppannotation.mli
@@ -23,7 +23,6 @@ type t =
   | 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
diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml
index e21bfa00..aa94fb7b 100644
--- a/printing/ppconstr.ml
+++ b/printing/ppconstr.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 (*i*)
-open Errors
+open CErrors
 open Util
 open Pp
 open Names
@@ -129,15 +129,13 @@ end) = struct
     str "`" ++ str hd ++ c ++ str tl
 
   let pr_com_at n =
-    if Flags.do_beautify() && not (Int.equal n 0) then comment n
+    if !Flags.beautify && not (Int.equal n 0) then comment (CLexer.extract_comments 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
@@ -151,13 +149,19 @@ end) = struct
     | GType [] -> tag_type (str "Type")
     | GType u -> hov 0 (tag_type (str "Type") ++ pr_univ_annot pr_univ u)
 
+  let pr_glob_level = function
+    | GProp -> tag_type (str "Prop")
+    | GSet -> tag_type (str "Set")
+    | GType None -> tag_type (str "Type")
+    | GType (Some (_, u)) -> tag_type (str u)
+
   let pr_qualid sp =
     let (sl, id) = repr_qualid sp in
-    let id = tag_ref (str (Id.to_string id)) in
+    let id = tag_ref (pr_id 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
+      let pr dir = tag_path (pr_id dir) ++ str "." in
       prlist pr sl
     in
     sl ++ id
@@ -182,7 +186,7 @@ end) = struct
 
   let pr_reference = function
   | Qualid (_, qid) -> pr_qualid qid
-  | Ident (_, id) -> tag_var (str (Id.to_string id))
+  | Ident (_, id) -> tag_var (pr_id id)
 
   let pr_cref ref us =
     pr_reference ref ++ pr_universe_instance us
@@ -246,16 +250,16 @@ end) = struct
       | CPatAlias (_, p, id) ->
         pr_patt mt (las,E) p ++ str " as " ++ pr_id id, las
 
-      | CPatCstr (_,c, [], []) ->
+      | CPatCstr (_,c, None, []) ->
         pr_reference c, latom
 
-      | CPatCstr (_, c, [], args) ->
+      | CPatCstr (_, c, None, args) ->
         pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp
 
-      | CPatCstr (_, c, args, []) ->
+      | CPatCstr (_, c, Some args, []) ->
         str "@" ++ pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp
 
-      | CPatCstr (_, c, expl_args, extra_args) ->
+      | CPatCstr (_, c, Some 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
 
@@ -281,6 +285,8 @@ end) = struct
 
       | CPatDelimiters (_,k,p) ->
         pr_delimiters k (pr_patt mt lsimplepatt p), 1
+      | CPatCast _ ->
+        assert false
     in
     let loc = cases_pattern_expr_loc p in
     pr_with_comments loc
@@ -300,6 +306,7 @@ end) = struct
   let begin_of_binder = function
   LocalRawDef((loc,_),_) -> fst (Loc.unloc loc)
     | LocalRawAssum((loc,_)::_,_,_) -> fst (Loc.unloc loc)
+    | LocalPattern(loc,_,_) -> fst (Loc.unloc loc)
     | _ -> assert false
 
   let begin_of_binders = function
@@ -348,6 +355,13 @@ end) = struct
         | _ -> c, CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) in
       surround (pr_lname na ++ pr_opt_type pr_c topt ++
                   str":=" ++ cut() ++ pr_c c)
+    | LocalPattern (loc,p,tyo) ->
+      let p = pr_patt lsimplepatt p in
+      match tyo with
+        | None ->
+          str "'" ++ p
+        | Some ty ->
+          str "'" ++ surround (p ++ spc () ++ str ":" ++ ws 1 ++ pr_c ty)
 
   let pr_undelimited_binders sep pr_c =
     prlist_with_sep sep (pr_binder_among_many pr_c)
@@ -356,13 +370,13 @@ end) = struct
     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
+        kw n ++ pr_binder false pr_c (nal,k,t)
+      | (LocalRawAssum _ | LocalPattern _) :: _ as bdl ->
+        kw n ++ 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
+    if is_open then pr_delimited_binders pr_com_at sep pr_c
     else pr_undelimited_binders sep pr_c
 
   let rec extract_prod_binders = function
@@ -371,6 +385,11 @@ end) = struct
       if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*)
     | CProdN (loc,[],c) ->
       extract_prod_binders c
+    | CProdN (loc,[[_,Name id],bk,t],
+              CCases (_,LetPatternStyle,None, [CRef (Ident (_,id'),None),None,None],[(_,[_,[p]],b)]))
+         when Id.equal id id' && not (Id.Set.mem id (Topconstr.free_vars_of_constr_expr b)) ->
+      let bl,c = extract_prod_binders b in
+      LocalPattern (loc,p,None) :: bl, 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
@@ -382,6 +401,11 @@ end) = struct
       if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*)
     | CLambdaN (loc,[],c) ->
       extract_lam_binders c
+    | CLambdaN (loc,[[_,Name id],bk,t],
+                CCases (_,LetPatternStyle,None, [CRef (Ident (_,id'),None),None,None],[(_,[_,[p]],b)]))
+         when Id.equal id id' && not (Id.Set.mem id (Topconstr.free_vars_of_constr_expr b)) ->
+      let bl,c = extract_lam_binders b in
+      LocalPattern (loc,p,None) :: bl, 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
@@ -432,6 +456,7 @@ end) = struct
             let names_of_binder = function
               | LocalRawAssum (nal,_,_) -> nal
               | LocalRawDef (_,_) -> []
+              | LocalPattern _ -> assert false
             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"}"
@@ -457,7 +482,7 @@ end) = struct
         (pr_decl true) dl ++
         fnl() ++ keyword "for" ++ spc () ++ pr_id id
 
-  let pr_asin pr (na,indnalopt) =
+  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 ()) ++
@@ -465,8 +490,8 @@ end) = struct
         | 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_item pr (tm,as_clause, in_clause) =
+    hov 0 (pr (lcast,E) tm ++ pr_asin pr as_clause in_clause)
 
   let pr_case_type pr po =
     match po with
@@ -495,9 +520,14 @@ end) = struct
       pr (lapp,L) a  ++
         prlist (fun a -> spc () ++ pr_expl_args pr a) l)
 
-  let pr_forall () = keyword "forall" ++ spc ()
+  let pr_record_body_gen pr l =
+    spc () ++
+    prlist_with_sep pr_semicolon
+      (fun (id, c) -> h 1 (pr_reference id ++ spc () ++ str":=" ++ pr ltop c)) l
 
-  let pr_fun () = keyword "fun" ++ spc ()
+  let pr_forall n = keyword "forall" ++ pr_com_at n ++ spc ()
+
+  let pr_fun n = keyword "fun" ++ pr_com_at n ++ spc ()
 
   let pr_fun_sep = spc () ++ str "=>"
 
@@ -595,28 +625,17 @@ end) = struct
           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
+      | CRecord (_,l) ->
         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" |}"),
+          hv 0 (str"{|" ++ pr_record_body_gen (pr spc) l ++ str" |}"),
           latom
         )
-      | CCases (_,LetPatternStyle,rtntypopt,[c,asin],[(_,[(loc,[p])],b)]) ->
+      | CCases (_,LetPatternStyle,rtntypopt,[c,as_clause,in_clause],[(_,[(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 ++
+                       pr_asin (pr_dangling_with_for mt pr) as_clause in_clause ++
                        str " :=" ++ pr spc ltop c ++
                        pr_case_type (pr_dangling_with_for mt pr) rtntypopt ++
                        spc () ++ keyword "in" ++ pr spc ltop b)),
@@ -741,6 +760,8 @@ end) = struct
 
   let pr_cases_pattern_expr = pr_patt ltop
 
+  let pr_record_body = pr_record_body_gen pr
+
   let pr_binders = pr_undelimited_binders spc (pr ltop)
 
 end
@@ -778,6 +799,22 @@ end
 
 let do_not_tag _ x = x
 
+let split_token tag s =
+  let len = String.length s in
+  let rec parse_string off i =
+    if Int.equal i len then
+      if Int.equal off i then mt () else tag (str (String.sub s off (i - off)))
+    else if s.[i] == ' ' then
+      if Int.equal off i then parse_space 1 (succ i)
+      else tag (str (String.sub s off (i - off))) ++ parse_space 1 (succ i)
+    else parse_string off (succ i)
+  and parse_space spc i =
+    if Int.equal i len then str (String.make spc ' ')
+    else if s.[i] == ' ' then parse_space (succ spc) (succ i)
+    else str (String.make spc ' ') ++ parse_string i (succ i)
+  in
+  parse_string 0 0
+
 (** Instantiating Make with tagging functions that only add style
     information. *)
 include Make (struct
@@ -786,7 +823,7 @@ include Make (struct
     let tag_evar        = tag Tag.evar
     let tag_type        = tag Tag.univ
     let tag_unparsing   = function
-    | UnpTerminal s -> tag Tag.notation
+    | UnpTerminal s -> fun _ -> split_token (fun pp -> tag Tag.notation pp) s
     | _ -> do_not_tag ()
     let tag_constr_expr = do_not_tag
     let tag_path = tag Tag.path
diff --git a/printing/ppconstrsig.mli b/printing/ppconstrsig.mli
index c711dd8f..3de0d805 100644
--- a/printing/ppconstrsig.mli
+++ b/printing/ppconstrsig.mli
@@ -44,12 +44,14 @@ module type Pp = sig
   val pr_qualid : qualid -> std_ppcmds
   val pr_patvar : patvar -> std_ppcmds
 
+  val pr_glob_level : glob_level -> 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_record_body : (reference * constr_expr) list -> 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
diff --git a/printing/pptactic.ml b/printing/pptactic.ml
index 7e903d2d..fcc30d70 100644
--- a/printing/pptactic.ml
+++ b/printing/pptactic.ml
@@ -9,11 +9,12 @@
 open Pp
 open Names
 open Namegen
-open Errors
+open CErrors
 open Util
 open Constrexpr
 open Tacexpr
 open Genarg
+open Geninterp
 open Constrarg
 open Libnames
 open Ppextend
@@ -26,22 +27,20 @@ open Printer
 
 let pr_global x = Nametab.pr_global_env Id.Set.empty x
 
-type grammar_terminals = string option list
+type 'a grammar_tactic_prod_item_expr =
+| TacTerm of string
+| TacNonTerm of Loc.t * 'a * Names.Id.t
+
+type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list
 
 type pp_tactic = {
-  pptac_args : argument_type list;
-  pptac_prods : int * grammar_terminals;
+  pptac_level : int;
+  pptac_prods : 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
 
@@ -60,14 +59,14 @@ type 'a glob_extra_genarg_printer =
 type 'a extra_genarg_printer =
     (Term.constr -> std_ppcmds) ->
     (Term.constr -> std_ppcmds) ->
-    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+    (tolerability -> Val.t -> 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
+  let s = match wit with
+    | ExtraArg s -> ArgT.repr s
     | _ -> error
       "Can declare a pretty-printing rule only for extra argument types."
   in
@@ -93,8 +92,6 @@ module Make
         : 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)
@@ -105,6 +102,39 @@ module Make
   let keyword x = tag_keyword (str x)
   let primitive x = tag_primitive (str x)
 
+  let has_type (Val.Dyn (tag, x)) t = match Val.eq tag t with
+  | None -> false
+  | Some _ -> true
+
+  let unbox : type a. Val.t -> a Val.typ -> a= fun (Val.Dyn (tag, x)) t ->
+  match Val.eq tag t with
+  | None -> assert false
+  | Some Refl -> x
+
+  let rec pr_value lev v : std_ppcmds =
+    if has_type v Val.typ_list then
+      pr_sequence (fun x -> pr_value lev x) (unbox v Val.typ_list)
+    else if has_type v Val.typ_opt then
+      pr_opt_no_spc (fun x -> pr_value lev x) (unbox v Val.typ_opt)
+    else if has_type v Val.typ_pair then
+      let (v1, v2) = unbox v Val.typ_pair in
+      str "(" ++ pr_value lev v1 ++ str ", " ++ pr_value lev v2 ++ str ")"
+    else
+      let Val.Dyn (tag, x) = v in
+      let name = Val.repr tag in
+      let default = str "<" ++ str name ++ str ">" in
+      match ArgT.name name with
+      | None -> default
+      | Some (ArgT.Any arg) ->
+        let wit = ExtraArg arg in
+        match val_tag (Topwit wit) with
+        | Val.Base t ->
+          begin match Val.eq t tag with
+          | None -> default
+          | Some Refl -> Genprint.generic_top_print (in_gen (Topwit wit) x)
+          end
+        | _ -> default
+
   let pr_with_occurrences pr (occs,c) =
     match occs with
       | AllOccurrences ->
@@ -121,7 +151,8 @@ module Make
   exception ComplexRedFlag
 
   let pr_short_red_flag pr r =
-    if not r.rBeta ||  not r.rIota ||  not r.rZeta then raise ComplexRedFlag
+    if not r.rBeta ||  not r.rMatch || not r.rFix || not r.rCofix || 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 ()) ++
@@ -131,9 +162,12 @@ module Make
     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.rMatch && r.rFix && r.rCofix then pr_arg str "iota" else
+           (if r.rMatch then pr_arg str "match" else mt ()) ++
+           (if r.rFix then pr_arg str "fix" else mt ()) ++
+           (if r.rCofix then pr_arg str "cofix" 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
@@ -150,7 +184,8 @@ module Make
     | 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
+      if f.rBeta && f.rMatch && f.rFix && f.rCofix &&
+           f.rZeta && f.rDelta && List.is_empty f.rConst then
         keyword "compute"
       else
         hov 1 (keyword "cbv" ++ pr_red_flag pr_ref f)
@@ -184,7 +219,7 @@ module Make
     | ConstrContext ((_,id),c) ->
       hov 0
         (keyword "context" ++ spc () ++ pr_id id ++ spc () ++
-           str "[" ++ prlc c ++ str "]")
+           str "[ " ++ prlc c ++ str " ]")
     | ConstrTypeOf c ->
       hov 1 (keyword "type of" ++ spc() ++ prc c)
     | ConstrTerm c when test c ->
@@ -240,8 +275,10 @@ module Make
     | NoBindings -> mt ()
 
   let pr_clear_flag clear_flag pp x =
-    (match clear_flag with Some false -> str "!" | Some true -> str ">" | None -> mt())
-    ++ pp x
+    match clear_flag with
+    | Some false -> surround (pp x)
+    | Some true -> str ">" ++ pp x
+    | None -> pp x
 
   let pr_with_bindings prc prlc (c,bl) =
     prc c ++ pr_bindings prc prlc bl
@@ -263,193 +300,177 @@ module Make
 
   let with_evars ev s = if ev then "e" ^ s else s
 
+  let hov_if_not_empty n p = if Pp.ismt p then p else hov n p
 
-  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
+  let rec pr_raw_generic_rec prc prlc prtac prpat prref (GenArg (Rawwit wit, x)) =
+    match wit with
+      | ListArg wit ->
+        let map x = pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) in
+        let ans = pr_sequence map x in
+        hov_if_not_empty 0 ans
+      | OptArg wit ->
+        let ans = match x with
           | None -> mt ()
-          | Some x -> pr_glb_generic prc prlc prtac prpat (in_gen (glbwit wit) x)
+          | Some x -> pr_raw_generic_rec 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 = 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
+        hov_if_not_empty 0 ans
+      | PairArg (wit1, wit2) ->
+        let p, q = x in
+        let p = in_gen (rawwit wit1) p in
+        let q = in_gen (rawwit wit2) q in
+        hov_if_not_empty 0 (pr_sequence (pr_raw_generic_rec prc prlc prtac prpat prref) [p; q])
+      | ExtraArg s ->
+        try pi1 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (rawwit wit) x)
+        with Not_found -> Genprint.generic_raw_print (in_gen (rawwit wit) x)
+
+
+  let rec pr_glb_generic_rec prc prlc prtac prpat (GenArg (Glbwit wit, x)) =
+    match wit with
+      | ListArg wit ->
+        let map x = pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) in
+        let ans = pr_sequence map x in
+        hov_if_not_empty 0 ans
+      | OptArg wit ->
+        let ans = match x 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]
+          | Some x -> pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x)
         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
+        hov_if_not_empty 0 ans
+      | PairArg (wit1, wit2) ->
+        let p, q = x in
+        let p = in_gen (glbwit wit1) p in
+        let q = in_gen (glbwit wit2) q in
+        let ans = pr_sequence (pr_glb_generic_rec prc prlc prtac prpat) [p; q] in
+        hov_if_not_empty 0 ans
+      | ExtraArg s ->
+        try pi2 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (glbwit wit) x)
+        with Not_found -> Genprint.generic_glb_print (in_gen (glbwit wit) 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"
+    | [] -> []
+    | TacTerm s :: l -> keyword s :: tacarg_using_rule_token pr_gen l
+    | TacNonTerm (_, (symb, arg), _) :: l  ->
+      pr_gen symb arg :: tacarg_using_rule_token pr_gen l
 
   let pr_tacarg_using_rule pr_gen l =
     let l = match l with
-    | (Some s :: l, al) ->
+    | TacTerm s :: l ->
       (** 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))
+      primitive s :: tacarg_using_rule_token pr_gen l
     | _ -> 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 pr_extend_gen pr_gen lev { mltac_name = s; mltac_index = i } l =
+      let name =
+        str s.mltac_plugin ++ str "::" ++ str s.mltac_tactic ++
+        str "@" ++ int i
+      in
       let args = match l with
         | [] -> mt ()
         | _ -> spc() ++ pr_sequence pr_gen l
       in
       str "<" ++ name ++ str ">" ++ args
 
+  let rec pr_user_symbol = function
+  | Extend.Ulist1 tkn -> "ne_" ^ pr_user_symbol tkn ^ "_list"
+  | Extend.Ulist1sep (tkn, _) -> "ne_" ^ pr_user_symbol tkn ^ "_list"
+  | Extend.Ulist0 tkn -> pr_user_symbol tkn ^ "_list"
+  | Extend.Ulist0sep (tkn, _) -> pr_user_symbol tkn ^ "_list"
+  | Extend.Uopt tkn -> pr_user_symbol tkn ^ "_opt"
+  | Extend.Uentry tag ->
+    let ArgT.Any tag = tag in
+    ArgT.repr tag
+  | Extend.Uentryl (tkn, lvl) -> "tactic" ^ string_of_int lvl
+
+  let pr_alias_key key =
+    try
+      let prods = (KNmap.find key !prnotation_tab).pptac_prods in
+      let rec pr = function
+      | TacTerm s -> primitive s
+      | TacNonTerm (_, symb, _) -> str (Printf.sprintf "(%s)" (pr_user_symbol symb))
+      in
+      pr_sequence pr prods
+    with Not_found ->
+      KerName.print key
+
   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
+      let rec pack prods args = match prods, args with
+      | [], [] -> []
+      | TacTerm s :: prods, args -> TacTerm s :: pack prods args
+      | TacNonTerm (loc, symb, id) :: prods, arg :: args ->
+        TacNonTerm (loc, (symb, arg), id) :: pack prods args
+      | _ -> raise Not_found
+      in
+      let prods = pack pp.pptac_prods l in
+      let p = pr_tacarg_using_rule pr_gen prods in
+      if pp.pptac_level > 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)
+      let pr arg = str "_" in
+      KerName.print key ++ spc() ++ pr_sequence pr l ++ str" (* Generic printer *)"
+
+  let pr_farg prtac arg = prtac (1, Any) (TacArg (Loc.ghost, arg))
+
+  let is_genarg tag wit =
+    let ArgT.Any tag = tag in
+    argument_type_eq (ArgumentType (ExtraArg tag)) wit
+
+  let get_list : type l. l generic_argument -> l generic_argument list option =
+  function (GenArg (wit, arg)) -> match wit with
+  | Rawwit (ListArg wit) -> Some (List.map (in_gen (rawwit wit)) arg)
+  | Glbwit (ListArg wit) -> Some (List.map (in_gen (glbwit wit)) arg)
+  | _ -> None
+
+  let get_opt : type l. l generic_argument -> l generic_argument option option =
+  function (GenArg (wit, arg)) -> match wit with
+  | Rawwit (OptArg wit) -> Some (Option.map (in_gen (rawwit wit)) arg)
+  | Glbwit (OptArg wit) -> Some (Option.map (in_gen (glbwit wit)) arg)
+  | _ -> None
+
+  let rec pr_any_arg : type l. (_ -> l generic_argument -> std_ppcmds) -> _ -> l generic_argument -> std_ppcmds =
+  fun prtac symb arg -> match symb with
+  | Extend.Uentry tag when is_genarg tag (genarg_tag arg) -> prtac (1, Any) arg
+  | Extend.Ulist1 s | Extend.Ulist0 s ->
+    begin match get_list arg with
+    | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
+    | Some l -> pr_sequence (pr_any_arg prtac s) l
+    end
+  | Extend.Ulist1sep (s, sep) | Extend.Ulist0sep (s, sep) ->
+    begin match get_list arg with
+    | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
+    | Some l -> prlist_with_sep (fun () -> str sep) (pr_any_arg prtac s) l
+    end
+  | Extend.Uopt s ->
+    begin match get_opt arg with
+    | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
+    | Some l -> pr_opt (pr_any_arg prtac s) l
+    end
+  | Extend.Uentry _ | Extend.Uentryl _ ->
+    str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
+
+  let rec pr_targ prtac symb arg = match symb with
+  | Extend.Uentry tag when is_genarg tag (ArgumentType wit_tactic) ->
+    prtac (1, Any) arg
+  | Extend.Uentryl (_, l) -> prtac (l, Any) arg
+  | _ ->
+    match arg with
+    | TacGeneric arg ->
+      let pr l arg = prtac l (TacGeneric arg) in
+      pr_any_arg pr symb arg
+    | _ -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
+
+  let pr_raw_extend_rec prc prlc prtac prpat =
+    pr_extend_gen (pr_farg prtac)
+  let pr_glob_extend_rec prc prlc prtac prpat =
+    pr_extend_gen (pr_farg prtac)
+
+  let pr_raw_alias prc prlc prtac prpat lev key args =
+    pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args
+  let pr_glob_alias prc prlc prtac prpat lev key args =
+    pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args
 
   (**********************************************************************)
   (* The tactic printer                                                 *)
@@ -514,10 +535,9 @@ module Make
 
   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, None -> hov 1 (pr_eqn_ipat eqpat)
+    | None, Some ipat -> 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 =
@@ -559,21 +579,21 @@ module Make
       spc() ++ prc c ++ pr_as_ipat prdc ipat
 
   let pr_by_tactic prt = function
-    | TacId [] -> mt ()
-    | tac -> spc() ++ keyword "by" ++ spc () ++ prt tac
+    | Some tac -> keyword "by" ++ spc () ++ prt tac
+    | None -> mt()
 
   let pr_hyp_location pr_id = function
-    | occs, InHyp -> spc () ++ pr_with_occurrences pr_id occs
+    | occs, InHyp -> pr_with_occurrences pr_id occs
     | occs, InHypTypeOnly ->
-      spc () ++ pr_with_occurrences (fun id ->
+      pr_with_occurrences (fun id ->
         str "(" ++ keyword "type of" ++ spc () ++ pr_id id ++ str ")"
       ) occs
     | occs, InHypValueOnly ->
-      spc () ++ pr_with_occurrences (fun id ->
+      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_in pp = hov 0 (keyword "in" ++ pp)
 
   let pr_simple_hyp_clause pr_id = function
     | [] -> mt ()
@@ -583,6 +603,17 @@ module Make
     | None -> mt ()
     | Some (id,ipat) -> pr_in (spc () ++ pr_id id) ++ pr_as_ipat prc ipat
 
+  let pr_in_clause pr_id = function
+    | { onhyps=None; concl_occs=NoOccurrences } ->
+      (str "* |-")
+    | { onhyps=None; concl_occs=occs } ->
+      (pr_with_occurrences (fun () -> str "*") (occs,()))
+    | { onhyps=Some l; concl_occs=NoOccurrences } ->
+      prlist_with_sep (fun () -> str ", ") (pr_hyp_location pr_id) l
+    | { onhyps=Some l; concl_occs=occs } ->
+      let pr_occs = pr_with_occurrences (fun () -> str" |- *") (occs,()) in
+      (prlist_with_sep (fun () -> str", ") (pr_hyp_location pr_id) l ++ pr_occs)
+
   let pr_clauses default_is_concl pr_id = function
     | { onhyps=Some []; concl_occs=occs }
         when (match default_is_concl with Some true -> true | _ -> false) ->
@@ -599,7 +630,8 @@ module Make
         | _ -> pr_with_occurrences (fun () -> str" |- *") (occs,())
       in
       pr_in
-        (prlist_with_sep (fun () -> str",") (pr_hyp_location pr_id) l ++ pr_occs)
+        (prlist_with_sep (fun () -> str",")
+           (fun id -> spc () ++ pr_hyp_location pr_id id) l ++ pr_occs)
 
   let pr_orient b = if b then mt () else str "<- "
 
@@ -610,16 +642,30 @@ module Make
     | RepeatStar -> str "?"
     | RepeatPlus -> str "!"
 
-  let pr_induction_arg prc prlc = function
+  let pr_core_destruction_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
+  let pr_destruction_arg prc prlc (clear_flag,h) =
+    pr_clear_flag clear_flag (pr_core_destruction_arg prc prlc) h
+                               
+  let pr_inversion_kind = function
     | SimpleInversion -> primitive "simple inversion"
     | FullInversion -> primitive "inversion"
     | FullInversionClear -> primitive "inversion_clear"
 
+  let pr_range_selector (i, j) =
+    if Int.equal i j then int i
+    else int i ++ str "-" ++ int j
+
+  let pr_goal_selector = function
+    | SelectNth i -> int i ++ str ":"
+    | SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++
+        str "]" ++ str ":"
+    | SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":"
+    | SelectAll -> str "all" ++ str ":"
+
   let pr_lazy = function
     | General -> keyword "multi"
     | Select -> keyword "lazy"
@@ -630,9 +676,9 @@ module Make
     | 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 "]"
+      keyword "context" ++ str" [ " ++ pr_pat a ++ str " ]"
     | Subterm (b,Some id,a) ->
-      keyword "context" ++ spc () ++ pr_id id ++ str "[" ++ pr_pat a ++ str "]"
+      keyword "context" ++ spc () ++ pr_id id ++ str "[ " ++ pr_pat a ++ str " ]"
 
   let pr_match_hyps pr_pat = function
     | Hyp (nal,mp) ->
@@ -706,20 +752,13 @@ module Make
             str " ]")
 
   let pr_hintbases = function
-    | None -> spc () ++ keyword "with" ++ str" *"
+    | None -> keyword "with" ++ str" *"
     | Some [] -> mt ()
-    | Some l ->
-      spc () ++ hov 2 (keyword "with" ++ prlist (fun s -> spc () ++ str s) l)
+    | Some l -> 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_"
+    | l -> hov 2 (keyword "using" ++ spc () ++ prlist_with_sep pr_comma prc l)
 
   let pr_then () = str ";"
 
@@ -746,7 +785,6 @@ module Make
   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;
@@ -755,13 +793,12 @@ module Make
     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;
+    pr_extend    : int -> ml_tactic_entry -> 'a gen_tactic_arg list -> std_ppcmds;
+    pr_alias     : int -> KerName.t -> 'a gen_tactic_arg list -> std_ppcmds;
   }
 
   constraint 'a = <
       term      :'trm;
-      utrm      :'utrm;
       dterm     :'dtrm;
       pattern   :'pat;
       constant  :'cst;
@@ -771,306 +808,216 @@ module Make
       level     :'lev
     >
 
-    let make_pr_tac pr strip_prod_binders tag_atom tag =
+    let pr_atom pr strip_prod_binders tag_atom =
+      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 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 (false,[]) -> primitive "intros"
+        | TacIntroPattern (true,[]) -> primitive "eintros"
+        | t -> str "(" ++ pr_atom1 t ++ str ")"
+      )
+
+      (* Main tactic printer *)
+      and pr_atom1 a = tag_atom a (match a with
+        (* Basic tactics *)
+        | TacIntroPattern (ev,[]) as t ->
+          pr_atom0 t
+        | TacIntroPattern (ev,(_::_ as p)) ->
+           hov 1 (primitive (if ev then "eintros" else "intros") ++ spc () ++
+                    prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p)
+        | 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_non_empty_arg (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)
+        | 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)
+        | 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_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) 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
+          )
+        | 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_non_empty_arg (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 (h,ids,cl) ->
+              pr_destruction_arg pr.pr_dconstr pr.pr_dconstr h ++
+                pr_non_empty_arg (pr_with_induction_names pr.pr_dconstr) ids ++
+                pr_opt (pr_clauses None pr.pr_name) cl) l ++
+              pr_opt pr_eliminator el
+          )
 
-        (* 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
+        (* Conversion *)
+        | TacReduce (r,h) ->
+          hov 1 (
+            pr_red_expr r
+            ++ pr_non_empty_arg (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_non_empty_arg (pr_clauses (Some true) pr.pr_name) h
+          )
 
-        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
+        (* Equality and inversion *)
+        | TacRewrite (ev,l,cl,tac) ->
+          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_non_empty_arg (pr_clauses (Some true) pr.pr_name) cl
+            ++ pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac
+          )
+        | TacInversion (DepInversion (k,c,ids),hyp) ->
+          hov 1 (
+            primitive "dependent " ++ pr_inversion_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_inversion_kind k ++ spc ()
+            ++ pr_quantified_hypothesis hyp
+            ++ pr_non_empty_arg (pr_with_inversion_names pr.pr_dconstr) ids
+            ++ pr_non_empty_arg (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_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl
+          )
+      )
+      in
+      pr_atom1
 
-        (* Some printing combinators *)
-        let pr_eliminator cb = keyword "using" ++ pr_arg pr_with_bindings cb in
+    let make_pr_tac pr strip_prod_binders tag_atom tag =
 
         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
@@ -1225,10 +1172,11 @@ module Make
               keyword "solve" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet
             | TacComplete t ->
               pr_tac (lcomplete,E) t, lcomplete
+            | TacSelect (s, tac) -> pr_goal_selector s ++ spc () ++ pr_tac ltop tac, latom
             | 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
+              pr_with_comments loc (hov 1 (pr_atom pr strip_prod_binders tag_atom t)), ltatom
             | TacArg(_,Tacexp e) ->
               pr.pr_tactic (latom,E) e, latom
             | TacArg(_,ConstrMayEval (ConstrTerm c)) ->
@@ -1251,26 +1199,17 @@ module Make
             | 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
+              pr_with_comments loc (pr.pr_alias (level_of inherited) kn 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 " [" ++ str (Dyn.tag t) ++ str "]>")
-          | MetaIdArg (loc,true,s) ->
-            pr_with_comments loc (str "$" ++ str s)
-          | MetaIdArg (loc,false,s) ->
-            pr_with_comments loc (keyword "constr:" ++ str " $" ++ 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 ->
@@ -1278,7 +1217,7 @@ module Make
           | TacNumgoals ->
             keyword "numgoals"
           | (TacCall _|Tacexp _ | TacGeneric _) as a ->
-            keyword "ltac:" ++ pr_tac (latom,E) (TacArg (Loc.ghost,a))
+            hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (Loc.ghost,a))))
 
         in pr_tac
 
@@ -1298,7 +1237,6 @@ module Make
     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;
@@ -1306,8 +1244,8 @@ module Make
       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_generic = pr_raw_generic_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr pr_reference;
+      pr_extend = pr_raw_extend_rec 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
@@ -1319,9 +1257,9 @@ module Make
 
   let pr_and_constr_expr pr (c,_) = pr c
 
-  let pr_pat_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 pr_glob_tactic_level env n t =
     let glob_printers =
       (strip_prod_binders_glob_constr)
     in
@@ -1329,7 +1267,6 @@ module Make
       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);
@@ -1337,8 +1274,10 @@ module Make
         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_generic = pr_glb_generic_rec
+          (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_extend = pr_glob_extend_rec
           (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
@@ -1363,39 +1302,49 @@ module Make
           | _ -> 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_atomic_tactic_level env n t =
+    let prtac n (t:atomic_tactic_expr) =
       let pr = {
-        pr_tactic = pr_glob_tactic_level env;
+        pr_tactic = (fun _ _ -> str "<tactic>");
         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_pattern = pr_constr_pattern_env env Evd.empty;
+        pr_lpattern = pr_lconstr_pattern_env env Evd.empty;
+        pr_constant = 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;
+        (** Those are not used by the atomic printer *)
+        pr_generic = (fun _ -> assert false);
+        pr_extend = (fun _ _ _ -> assert false);
+        pr_alias = (fun _ _ _ -> assert false);
       }
       in
-      make_pr_tac
-        pr typed_printers
-        tag_atomic_tactic_expr tag_tactic_expr
-        n t
+      pr_atom pr strip_prod_binders_constr tag_atomic_tactic_expr t
     in
     prtac n t
 
-  let pr_tactic env = pr_tactic_level env ltop
+  let pr_raw_generic env = pr_raw_generic_rec
+    pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr pr_reference
+
+  let pr_glb_generic env = pr_glb_generic_rec
+    (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env))
+    (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env))
+
+  let pr_raw_extend env = pr_raw_extend_rec
+    pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr
+
+  let pr_glob_extend env = pr_glob_extend_rec
+    (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env))
+    (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env))
+
+  let pr_alias pr lev key args =
+    pr_alias_gen (fun _ arg -> pr arg) lev key args
+
+  let pr_extend pr lev ml args =
+    pr_extend_gen pr lev ml args
+
+  let pr_atomic_tactic env = pr_atomic_tactic_level env ltop
 
 end
 
@@ -1425,37 +1374,77 @@ include Make (Ppconstr) (struct
     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 run_delayed c =
+  Sigma.run Evd.empty { Sigma.run = fun sigma -> c.delayed (Global.env ()) sigma }
+
+let run_delayed_destruction_arg = function (* HH: Using Evd.empty looks suspicious *)
+  | clear_flag,ElimOnConstr g -> clear_flag,ElimOnConstr (fst (run_delayed g))
+  | clear_flag,ElimOnAnonHyp n as x -> x
+  | clear_flag,ElimOnIdent id as x -> x
+
 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_int_or_var
+    (pr_or_var int) (pr_or_var int) int;
   Genprint.register_print0 Constrarg.wit_ref
     pr_reference (pr_or_var (pr_located pr_global)) pr_global;
+  Genprint.register_print0 Constrarg.wit_ident
+    pr_id pr_id pr_id;
+  Genprint.register_print0 Constrarg.wit_var
+    (pr_located pr_id) (pr_located pr_id) pr_id;
   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))));
+    (Miscprint.pr_intro_pattern (fun c -> pr_constr (fst (run_delayed c))));
   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_constr
+    Ppconstr.pr_constr_expr
+    (fun (c, _) -> Printer.pr_glob_constr c)
+    Printer.pr_constr
+  ;
   Genprint.register_print0
     Constrarg.wit_uconstr
     Ppconstr.pr_constr_expr
     (fun (c,_) -> Printer.pr_glob_constr c)
     Printer.pr_closed_glob
   ;
+  Genprint.register_print0
+    Constrarg.wit_open_constr
+    Ppconstr.pr_constr_expr
+    (fun (c, _) -> Printer.pr_glob_constr c)
+    Printer.pr_constr
+  ;
+  Genprint.register_print0 Constrarg.wit_red_expr
+    (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr))
+    (pr_red_expr (pr_and_constr_expr pr_glob_constr, pr_lglob_constr, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr))
+    (pr_red_expr (pr_constr, pr_lconstr, pr_evaluable_reference, pr_constr_pattern));
+  Genprint.register_print0 Constrarg.wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis;
+  Genprint.register_print0 Constrarg.wit_bindings
+    (pr_bindings_no_with pr_constr_expr pr_lconstr_expr)
+    (pr_bindings_no_with (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr))
+    (fun it -> pr_bindings_no_with pr_constr pr_lconstr (fst (run_delayed it)));
+  Genprint.register_print0 Constrarg.wit_constr_with_bindings
+    (pr_with_bindings pr_constr_expr pr_lconstr_expr)
+    (pr_with_bindings (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr))
+    (fun it -> pr_with_bindings pr_constr pr_lconstr (fst (run_delayed it)));
+  Genprint.register_print0 Constrarg.wit_destruction_arg
+    (pr_destruction_arg pr_constr_expr pr_lconstr_expr)
+    (pr_destruction_arg (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr))
+    (fun it -> pr_destruction_arg pr_constr pr_lconstr (run_delayed_destruction_arg it));
   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;
@@ -1466,16 +1455,10 @@ 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)
+let () =
+  let pr_unit _ _ _ () = str "()" in
+  let printer _ _ prtac = prtac (0, E) in
+  declare_extra_genarg_pprule wit_ltac printer printer pr_unit
 
 module Richpp = struct
 
@@ -1490,7 +1473,6 @@ module Richpp = struct
     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)
 
diff --git a/printing/pptactic.mli b/printing/pptactic.mli
index 31346561..86e3ea54 100644
--- a/printing/pptactic.mli
+++ b/printing/pptactic.mli
@@ -11,11 +11,15 @@
 
 open Pp
 open Genarg
+open Geninterp
 open Names
 open Constrexpr
 open Tacexpr
 open Ppextend
 
+type 'a grammar_tactic_prod_item_expr =
+| TacTerm of string
+| TacNonTerm of Loc.t * 'a * Names.Id.t
 
 type 'a raw_extra_genarg_printer =
     (constr_expr -> std_ppcmds) ->
@@ -32,7 +36,7 @@ type 'a glob_extra_genarg_printer =
 type 'a extra_genarg_printer =
     (Term.constr -> std_ppcmds) ->
     (Term.constr -> std_ppcmds) ->
-    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+    (tolerability -> Val.t -> std_ppcmds) ->
     'a -> std_ppcmds
 
 val declare_extra_genarg_pprule :
@@ -41,14 +45,13 @@ val declare_extra_genarg_pprule :
   'b glob_extra_genarg_printer ->
   'c extra_genarg_printer -> unit
 
-type grammar_terminals = string option list
+type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list
 
 type pp_tactic = {
-  pptac_args : argument_type list;
-  pptac_prods : int * grammar_terminals;
+  pptac_level : int;
+  pptac_prods : 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
diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli
index b2323acb..665e055f 100644
--- a/printing/pptacticsig.mli
+++ b/printing/pptacticsig.mli
@@ -8,11 +8,10 @@
 
 open Pp
 open Genarg
-open Constrexpr
+open Geninterp
 open Tacexpr
 open Ppextend
 open Environ
-open Pattern
 open Misctypes
 
 module type Pp = sig
@@ -30,48 +29,31 @@ module type Pp = sig
   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_in_clause :
+    ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.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_raw_generic : env -> rlevel generic_argument -> std_ppcmds
+
+  val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds
+
+  val pr_raw_extend: env -> int ->
+    ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds
+
+  val pr_glob_extend: env -> int ->
+    ml_tactic_entry -> glob_tactic_arg 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.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds
+
+  val pr_alias_key : Names.KerName.t -> std_ppcmds
+
+  val pr_alias : (Val.t -> std_ppcmds) ->
+    int -> Names.KerName.t -> Val.t list -> std_ppcmds
+
+  val pr_alias_key : Names.KerName.t -> std_ppcmds
 
   val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds
 
@@ -81,7 +63,7 @@ module type Pp = sig
 
   val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds
 
-  val pr_tactic : env -> tactic_expr -> std_ppcmds
+  val pr_atomic_tactic : env -> atomic_tactic_expr -> std_ppcmds
 
   val pr_hintbases : string list option -> std_ppcmds
 
@@ -91,4 +73,11 @@ module type Pp = sig
     ('constr -> std_ppcmds) ->
     ('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds
 
+  val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds
+
+  val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
+    ('b, 'a) match_rule -> std_ppcmds
+
+  val pr_value : tolerability -> Val.t -> std_ppcmds
+
 end
diff --git a/printing/pputils.ml b/printing/pputils.ml
index 906b463a..50ce56fb 100644
--- a/printing/pputils.ml
+++ b/printing/pputils.ml
@@ -9,7 +9,11 @@
 open Pp
 
 let pr_located pr (loc, x) =
-  if Flags.do_beautify () && loc <> Loc.ghost then
+  if !Flags.beautify && loc <> Loc.ghost then
     let (b, e) = Loc.unloc loc in
-    Pp.comment b ++ pr x ++ Pp.comment e
+    (* Side-effect: order matters *)
+    let before = Pp.comment (CLexer.extract_comments b) in
+    let x = pr x in
+    let after = Pp.comment (CLexer.extract_comments e) in
+    before ++ x ++ after
   else pr x
diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml
index d2f59e7b..5d6d36d5 100644
--- a/printing/ppvernac.ml
+++ b/printing/ppvernac.ml
@@ -9,7 +9,7 @@
 open Pp
 open Names
 
-open Errors
+open CErrors
 open Util
 open Extend
 open Vernacexpr
@@ -34,6 +34,8 @@ module Make
 
   let keyword s = tag_keyword (str s)
 
+  let pr_constr = pr_constr_expr
+  let pr_lconstr = pr_lconstr_expr
   let pr_spc_lconstr = pr_sep_com spc pr_lconstr_expr
 
   let pr_lident (loc,id) =
@@ -79,21 +81,11 @@ module Make
     | 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 pr_gen t = pr_raw_generic (Global.env ()) 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"
@@ -105,18 +97,6 @@ module Make
     | 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
@@ -181,14 +161,22 @@ module Make
     | HintsReference r -> pr_reference r
     | HintsConstr c -> pr_c c
 
+  let pr_hint_mode = function
+    | ModeInput -> str"+"
+    | ModeNoHeadEvar -> str"!"
+    | ModeOutput -> str"-"
+
+  let pr_hint_info pr_pat { hint_priority = pri; hint_pattern = pat } =
+    pr_opt (fun x -> str"|" ++ int x) pri ++
+    pr_opt (fun y -> (if Option.is_empty pri then str"| " else mt()) ++ pr_pat y) pat
+
   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 ())
+            (fun (info, _, c) -> pr_reference_or_constr pr_c c ++ pr_hint_info pr_pat info)
             l
         | HintsImmediate l ->
           keyword "Immediate" ++ spc() ++
@@ -202,8 +190,8 @@ module Make
         | HintsMode (m, l) ->
           keyword "Mode"
           ++ spc ()
-          ++ pr_reference m ++ spc() ++ prlist_with_sep spc
-            (fun b -> if b then str"+" else str"-") l
+          ++ pr_reference m ++ spc() ++
+            prlist_with_sep spc pr_hint_mode l
         | HintsConstructors c ->
           keyword "Constructors"
           ++ spc() ++ prlist_with_sep spc pr_reference c
@@ -243,6 +231,11 @@ module Make
     | NoInline -> str "[no inline]"
     | InlineAt i -> str "[inline at level " ++ int i ++ str "]"
 
+  let pr_assumption_inline = function
+    | DefaultInline -> str "Inline"
+    | NoInline -> mt ()
+    | InlineAt i -> str "Inline(" ++ 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
 
@@ -272,11 +265,12 @@ module Make
     | _ 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 ++
+    fnl () ++ keyword "where " ++ qs ntn ++ str " := "
+    ++ Flags.without_option Flags.beautify prc c ++
       pr_opt (fun sc -> str ": " ++ str sc) scopt
 
   let pr_binders_arg =
-    pr_ne_sep spc pr_binders
+    pr_non_empty_arg pr_binders
 
   let pr_and_type_binders_arg bl =
     pr_binders_arg bl
@@ -375,8 +369,9 @@ module Make
     | 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 ^ "\"")
+    | SetOnlyPrinting -> keyword "only printing"
+    | SetOnlyParsing -> keyword "only parsing"
+    | SetCompatVersion 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
 
@@ -385,22 +380,19 @@ module Make
     | 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_univs pl =
     match pl with
     | None -> mt ()
     | Some pl -> str"@{" ++ prlist_with_sep spc pr_lident pl ++ str"}"
 
+  let pr_rec_definition ((((loc,id),pl),ro,bl,type_,def),ntn) =
+    let pr_pure_lconstr c = Flags.without_option Flags.beautify pr_lconstr c in
+    let annot = pr_guard_annot pr_lconstr_expr bl ro in
+    pr_id id ++ pr_univs pl ++ 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_pure_lconstr def) def
+    ++ prlist (pr_decl_notation pr_constr) ntn
+
   let pr_statement head (idpl,(bl,c,guard)) =
     assert (not (Option.is_empty idpl));
     let id, pl = Option.get idpl in
@@ -417,894 +409,843 @@ module Make
 (**************************************)
 (* 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"
+  let pr_constrarg c = spc () ++ pr_constr c
+  let pr_lconstrarg c = spc () ++ pr_lconstr c
+  let pr_intarg n = spc () ++ int n
+
+  let pr_oc = function
+    | None -> str" :"
+    | Some true -> str" :>"
+    | Some false -> str" :>>"
+
+  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
+
+  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"}")
+
+  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
+    | 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
+    | 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
+
+  let pr_using e = str (Proof_using.to_string e)
+
+  let rec pr_vernac_body 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 ++ spc () ++ pr_vernac_body v)
+      | VernacProgram v ->
+        return (keyword "Program" ++ spc() ++ pr_vernac_body v)
+      | VernacLocal (local, v) ->
+        return (pr_locality local ++ spc() ++ pr_vernac_body 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_body v)
+      | VernacStm (PGLast v) ->
+        return (keyword "Stm PGLast " ++ pr_vernac_body 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 id -> spc () ++ pr_id id
+          | GoalUid 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_reference id
+          | ShowThesis -> keyword "Show Thesis"
         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"
+        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_body v)
+      | VernacRedirect (s, (_,v)) ->
+        return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac_body v)
+      | VernacTimeout(n,v) ->
+        return (keyword "Timeout " ++ int n ++ spc() ++ pr_vernac_body v)
+      | VernacFail v ->
+        return (keyword "Fail" ++ spc() ++ pr_vernac_body v)
+      | VernacError _ ->
+        return (keyword "No-parsing-rule for VernacError")
+
+    (* Syntax *)
+      | VernacOpenCloseScope (_,(opening,sc)) ->
+        return (
+          keyword (if opening then "Open " else "Close ") ++
+            keyword "Scope" ++ spc() ++ str sc
+        )
+      | VernacDelimiters (sc,Some key) ->
+        return (
+          keyword "Delimit Scope" ++ spc () ++ str sc ++
+            spc() ++ keyword "with" ++ spc () ++ str key
+        )
+      | VernacDelimiters (sc, None) ->
+        return (
+          keyword "Undelimit Scope" ++ spc () ++ str sc
+        )
+      | VernacBindScope (sc,cll) ->
+        return (
+          keyword "Bind Scope" ++ spc () ++ str sc ++
+            spc() ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_class_rawexpr cll
+        )
+      | VernacArgumentsScope (q,scl) ->
+        let pr_opt_scope = function
+          | None -> str"_"
+          | Some sc -> str sc
         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
+        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) ->
+        return (
+          hov 2 (keyword "Notation" ++ spc() ++ qs s ++
+                   str " :=" ++ Flags.without_option Flags.beautify 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_plident 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 -> (match opac with
+              | Transparent -> keyword "Defined"
+              | Opaque None -> keyword "Qed"
+              | Opaque (Some l) ->
+                  keyword "Qed" ++ spc() ++ str"export" ++
+                    prlist_with_sep (fun () -> str", ") pr_lident l)
+          | Some (id,th) -> (match th with
+              | None -> (if opac <> Transparent 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,t,l) ->
+        let n = List.length (List.flatten (List.map fst (List.map snd l))) in
+        let pr_params (c, (xl, t)) =
+          hov 2 (prlist_with_sep sep pr_plident xl ++ spc() ++
+            (if c then str":>" else str":" ++ spc() ++ pr_lconstr_expr t)) in
+        let assumptions = prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params p ++ str ")")) l in
+        return (hov 2 (pr_assumption_token (n > 1) stre ++
+                       pr_non_empty_arg pr_assumption_inline t ++ spc() ++ assumptions))
+      | VernacInductive (p,f,l) ->
+        let pr_constructor (coe,(id,c)) =
+          hov 2 (pr_lident id ++ str" " ++
+                   (if coe then str":>" else str":") ++
+                   Flags.without_option Flags.beautify 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,pl)),indpar,s,k,lc),ntn) =
+          hov 0 (
+            str key ++ spc() ++
+              (if coe then str"> " else str"") ++ pr_lident id ++ pr_univs pl ++
+              pr_and_type_binders_arg indpar ++
+              pr_opt (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) 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
+        return (
+          hov 0 (str local ++ keyword "Fixpoint" ++ spc () ++
+                   prlist_with_sep (fun _ -> fnl () ++ keyword "with"
+                     ++ spc ()) pr_rec_definition 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),pl),bl,c,def),ntn) =
+          pr_id id ++ pr_univs pl ++ 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_glob_level l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++
+            pr_glob_level 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 (from, exp, l) ->
+        let from = match from with
+        | None -> mt ()
+        | Some r -> keyword "From" ++ spc () ++ pr_module r ++ spc ()
+        in
+        return (
+          hov 2
+            (from ++ 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, info) ->
+        return (
+          hov 1 (
+            (if abst then keyword "Declare" ++ spc () else mt ()) ++
+              keyword "Instance" ++
+              (match instid with
+      	 | (loc, Name id), l -> spc () ++ pr_plident ((loc, id),l) ++ spc () 
+               | (_, Anonymous), _ -> mt ()) ++
+              pr_and_type_binders_arg sup ++
+              str":" ++ spc () ++
+              (match bk with Implicit -> str "! " | Explicit -> mt ()) ++
+              pr_constr cl ++ pr_hint_info pr_constr_pattern_expr info ++
+              (match props with
+                | Some (true,CRecord (_,l)) -> spc () ++ str":=" ++ spc () ++ str"{" ++ pr_record_body l ++ str "}"
+                | Some (true,_) -> assert false
+                | Some (false,p) -> spc () ++ str":=" ++ spc () ++ pr_constr p
+                | None -> mt()))
+        )
+
+      | VernacContext l ->
+        return (
+          hov 1 (
+            keyword "Context" ++ pr_and_type_binders_arg l)
+        )
+
+      | VernacDeclareInstances insts ->
+         let pr_inst (id, info) =
+           pr_reference id ++ pr_hint_info pr_constr_pattern_expr info
+         in
+         return (
+          hov 1 (keyword "Existing" ++ spc () ++
+                   keyword(String.plural (List.length insts) "Instance") ++
+                 spc () ++ prlist_with_sep (fun () -> str", ") pr_inst insts)
+        )
+
+      | 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 ++ str " :" ++
+                   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 *)
+      | 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)
 
-    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 id -> spc () ++ pr_id id
-            | GoalUid 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)
-        | VernacRedirect (s, v) ->
-          return (keyword "Redirect" ++ spc() ++ qs s ++ 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,Some key) ->
-          return (
-            keyword "Delimit Scope" ++ spc () ++ str sc ++
-              spc() ++ keyword "with" ++ spc () ++ str key
-          )
-        | VernacDelimiters (sc, None) ->
-          return (
-            keyword "Undelimit Scope" ++ spc () ++ str sc
-          )
-        | 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
+      (* Commands *)
+      | 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),_,compat) ->
+        return (
+          hov 2
+            (keyword "Notation" ++ spc () ++ pr_lident id ++ spc () ++
+               prlist_with_sep spc pr_id ids ++ str":=" ++ pr_constrarg c ++
+               pr_syntax_modifiers
+               (match compat with
+                | None -> []
+                | Some Flags.Current -> [SetOnlyParsing]
+                | Some v -> [SetCompatVersion 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, args, more_implicits, 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 x = match imp with
+                | Vernacexpr.Implicit -> str "[" ++ x ++ str "]"
+                | Vernacexpr.MaximallyImplicit -> str "{" ++ x ++ str "}"
+                | Vernacexpr.NotImplicit -> x in
+              let rec print_arguments n l =
+                match n, l with
+                  | Some 0, l -> spc () ++ str"/" ++ print_arguments None l
+                  | _, [] -> mt()
+                  | n, { name = id; recarg_like = k;
+                         notation_scope = s;
+                         implicit_status = imp } :: tl ->
+                    spc() ++ pr_br imp (pr_if k (str"!") ++ pr_name id ++ pr_s s) ++
+                      print_arguments (Option.map pred n) tl
+              in
+              let rec print_implicits = function
+                | [] -> mt ()
+                | (name, impl) :: rest ->
+                   spc() ++ pr_br impl (pr_name name) ++ print_implicits rest
               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_plident 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 -> (match opac with
-                | Transparent -> keyword "Defined"
-                | Opaque None -> keyword "Qed"
-                | Opaque (Some l) ->
-                    keyword "Qed" ++ spc() ++ str"export" ++
-                      prlist_with_sep (fun () -> str", ") pr_lident l)
-            | Some (id,th) -> (match th with
-                | None -> (if opac <> Transparent then keyword "Save" else keyword "Defined") ++ spc() ++ pr_lident id
-                | Some tok -> keyword "Save" ++ spc() ++ pr_thm_token tok ++ spc() ++ pr_lident id)
+              print_arguments nargs args ++
+                if not (List.is_empty more_implicits) then
+                  prlist (fun l -> str"," ++ print_implicits l) more_implicits
+                else (mt ()) ++
+                (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)
         )
-        | 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
-          let pr_params (c, (xl, t)) =
-            hov 2 (prlist_with_sep sep pr_plident xl ++ spc() ++
-              (if c then str":>" else str":" ++ spc() ++ pr_lconstr_expr t))
-          in
-          let assumptions = prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params p ++ str ")")) l in
-          return (hov 2 (pr_assumption_token (n > 1) stre ++ spc() ++ assumptions))
-        | 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,pl)),indpar,s,k,lc),ntn) =
-            hov 0 (
-              str key ++ spc() ++
-                (if coe then str"> " else str"") ++ pr_lident id ++ pr_univs pl ++
-                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),pl),ro,bl,type_,def),ntn ->
-              let annot = pr_guard_annot pr_lconstr_expr bl ro in
-              pr_id id ++ pr_univs pl ++ 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),pl),bl,c,def),ntn) =
-            pr_id id ++ pr_univs pl ++ 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 (from, exp, l) ->
-          let from = match from with
-          | None -> mt ()
-          | Some r -> keyword "From" ++ spc () ++ pr_module r ++ spc ()
-          in
-          return (
-            hov 2
-              (from ++ 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"
+      | VernacSetOpacity(Conv_oracle.Opaque,l) ->
+        return (
+          hov 1 (keyword "Opaque" ++
+                   spc() ++ prlist_with_sep sep pr_smart_global l)
+        )
+      | VernacSetOpacity _ ->
+        return (
+          CErrors.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_info =
-          match info with
-            | None -> mt ()
-            | Some i -> str"Info"++spc()++int i++spc()
+        let pr_line (l,q) =
+          hov 2 (pr_lev l ++ spc() ++
+                   str"[" ++ prlist_with_sep sep pr_smart_global q ++ str"]")
         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 ())
+          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)
+        )
+      | VernacSetAppendOption (na,v) ->
+        return (
+          hov 2 (keyword "Set" ++ spc() ++ pr_printoption na None ++
+                   spc() ++ keyword "Append" ++ spc() ++ qs 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)
+        )
+
+      (* 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
         )
-        | 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 " ++ str (fst s) ++ str ">" 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(" ++ str (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
+      | 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)
+      | VernacSubproof None ->
+        return (str "{")
+      | VernacSubproof (Some i) ->
+        return (keyword "BeginSubproof" ++ spc () ++ int i)
+      | VernacEndSubproof ->
+        return (str "}")
+
+  and pr_extend s cl =
+    let pr_arg a =
+      try pr_gen a
+      with Failure _ -> str "<error in " ++ str (fst s) ++ str ">" in
+    try
+      let rl = Egramml.get_extend_vernac_rule s in
+      let rec aux rl cl =
+        match rl, cl with
+        | Egramml.GramNonTerminal _ :: rl, arg :: cl -> pr_arg arg :: aux rl cl
+        | Egramml.GramTerminal s :: rl, cl -> str s :: aux rl cl
+        | [], [] -> []
+        | _ -> assert false in
+      hov 1 (pr_sequence (fun x -> x) (aux rl cl))
+    with Not_found ->
+      hov 1 (str "TODO(" ++ str (fst s) ++ spc () ++ prlist_with_sep sep pr_arg cl ++ str ")")
+
+  let pr_vernac v =
+    try pr_vernac_body v ++ sep_end v
+    with e -> CErrors.print e
 
 end
 
diff --git a/printing/ppvernacsig.mli b/printing/ppvernacsig.mli
index 5d1c8933..5e5e4bcf 100644
--- a/printing/ppvernacsig.mli
+++ b/printing/ppvernacsig.mli
@@ -8,6 +8,9 @@
 
 module type Pp = sig
 
+  (** Prints a fixpoint body *)
+  val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.std_ppcmds
+
   (** Prints a vernac expression *)
   val pr_vernac_body : Vernacexpr.vernac_expr -> Pp.std_ppcmds
 
diff --git a/printing/prettyp.ml b/printing/prettyp.ml
index fd51fd6b..e117f1dc 100644
--- a/printing/prettyp.ml
+++ b/printing/prettyp.ml
@@ -11,7 +11,7 @@
  *)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
@@ -35,7 +35,7 @@ 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          : Id.t * constr option * types -> std_ppcmds;
+  print_named_decl          : Context.Named.Declaration.t -> 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 -> Evd.evar_map -> Term.constr * Term.types -> Pp.std_ppcmds;
@@ -132,7 +132,8 @@ let print_renames_list prefix l =
 let need_expansion impl ref =
   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
+  let open Context.Rel.Declaration in
+  let nprods = List.count is_local_assum ctx in
   not (List.is_empty impl) && List.length impl >= nprods &&
     let _,lastimpl = List.chop nprods impl in
       List.exists is_status_implicit lastimpl
@@ -168,8 +169,10 @@ type opacity =
   | FullyOpaque
   | TransparentMaybeOpacified of Conv_oracle.level
 
-let opacity env = function
-  | VarRef v when not (Option.is_empty (pi2 (Environ.lookup_named v env))) ->
+let opacity env =
+  let open Context.Named.Declaration in
+  function
+  | VarRef v when is_local_def (Environ.lookup_named v env) ->
       Some(TransparentMaybeOpacified
         (Conv_oracle.get_strategy (Environ.oracle env) (VarKey v)))
   | ConstRef cst ->
@@ -212,15 +215,21 @@ let print_polymorphism ref =
        else "not universe polymorphic") ]
   else []
 
+let print_type_in_type ref =
+  let unsafe = Global.is_type_in_type ref in
+  if unsafe then
+    [ pr_global ref ++ str " relies on an unsafe universe hierarchy"]
+  else []
+
 let print_primitive_record recflag mipv = function
   | Some (Some (_, ps,_)) ->
     let eta = match recflag with
-    | Decl_kinds.CoFinite -> mt ()
-    | Decl_kinds.Finite | Decl_kinds.BiFinite -> str " and has eta conversion"
+    | Decl_kinds.CoFinite | Decl_kinds.Finite -> str" without eta conversion"
+    | Decl_kinds.BiFinite -> str " with eta conversion"
     in
-    [pr_id mipv.(0).mind_typename ++ str" is primitive" ++ eta ++ str"."]
+    [pr_id mipv.(0).mind_typename ++ str" has primitive projections" ++ eta ++ str"."]
   | _ -> []
-    
+
 let print_primitive ref =
   match ref with 
   | IndRef ind -> 
@@ -232,7 +241,7 @@ let print_name_infos ref =
   let impls = implicits_of_global ref in
   let scopes = Notation.find_arguments_scope ref in
   let renames =
-    try List.hd (Arguments_renaming.arguments_names ref) with Not_found -> [] in
+    try Arguments_renaming.arguments_names ref with Not_found -> [] in
   let type_info_for_implicit =
     if need_expansion (select_impargs_size 0 impls) ref then
       (* Need to reduce since implicits are computed with products flattened *)
@@ -241,6 +250,7 @@ let print_name_infos ref =
     else
       [] in
   print_polymorphism ref @
+  print_type_in_type ref @
   print_primitive ref @
   type_info_for_implicit @
   print_renames_list (mt()) renames @
@@ -271,7 +281,7 @@ let print_inductive_implicit_args =
 let print_inductive_renames =
   print_args_data_of_inductive_ids
     (fun r ->
-      try List.hd (Arguments_renaming.arguments_names r) with Not_found -> [])
+      try Arguments_renaming.arguments_names r with Not_found -> [])
     ((!=) Anonymous)
     print_renames_list
 
@@ -440,11 +450,13 @@ let print_named_def name body typ =
 let print_named_assum name typ =
   str "*** [" ++ str name ++ str " : " ++ pr_ltype typ ++ str "]"
 
-let gallina_print_named_decl (id,c,typ) =
-  let s = Id.to_string id in
-  match c with
-    | Some body -> print_named_def s body typ
-    | None -> print_named_assum s typ
+let gallina_print_named_decl =
+  let open Context.Named.Declaration in
+  function
+  | LocalAssum (id, typ) ->
+     print_named_assum (Id.to_string id) typ
+  | LocalDef (id, body, typ) ->
+     print_named_def (Id.to_string id) body typ
 
 let assumptions_for_print lna =
   List.fold_right (fun na env -> add_name na env) lna empty_names_context
@@ -721,8 +733,8 @@ let print_any_name = function
   try  (* Var locale de but, pas var de section... donc pas d'implicits *)
     let dir,str = repr_qualid qid in
     if not (DirPath.is_empty dir) then raise Not_found;
-    let (_,c,typ) = Global.lookup_named str in
-    (print_named_decl (str,c,typ))
+    let open Context.Named.Declaration in
+    str |> Global.lookup_named |> set_id str |> print_named_decl
   with Not_found ->
     errorlabstrm
       "print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.")
@@ -750,8 +762,8 @@ let print_opaque_name qid =
 	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
-	print_named_decl (id,c,ty)
+        let open Context.Named.Declaration in
+        lookup_named id env |> set_id id |> print_named_decl
 
 let print_about_any loc k =
   match k with
@@ -860,7 +872,7 @@ let pr_instance env i =
   (*   gallina_print_constant_with_infos i.is_impl *)
   (* lighter *)
   print_ref false (instance_impl i) ++
-  begin match instance_priority i with
+  begin match hint_priority i with
   | None -> mt ()
   | Some i -> spc () ++ str "|" ++ spc () ++ int i
   end
diff --git a/printing/prettyp.mli b/printing/prettyp.mli
index 6f3556ad..0eab1557 100644
--- a/printing/prettyp.mli
+++ b/printing/prettyp.mli
@@ -66,7 +66,7 @@ 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          : Id.t * constr option * types -> std_ppcmds;
+  print_named_decl          : Context.Named.Declaration.t -> 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 -> Evd.evar_map -> Term.constr * Term.types -> Pp.std_ppcmds;
diff --git a/printing/printer.ml b/printing/printer.ml
index 5ad0e453..04337f6b 100644
--- a/printing/printer.ml
+++ b/printing/printer.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Term
@@ -28,9 +28,7 @@ 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())
+  Pfedit.get_current_context ()
 
 (**********************************************************************)
 (** Terms                                                             *)
@@ -50,7 +48,7 @@ let pr_lconstr_core 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 _ = Hook.set Refine.pr_constr pr_constr_env
 
 let pr_lconstr_goal_style_env env = pr_lconstr_core true env
 let pr_constr_goal_style_env env = pr_constr_core true env
@@ -186,7 +184,7 @@ 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
-    with e when Errors.noncritical e ->
+    with e when CErrors.noncritical e ->
       Libnames.Qualid (loc, qualid_of_global env r)
   in
   Constrextern.set_extern_reference extern_ref;
@@ -194,7 +192,7 @@ let safe_gen f env sigma c =
     let p = f env sigma c in
     Constrextern.set_extern_reference orig_extern_ref;
     p
-  with e when Errors.noncritical e ->
+  with e when CErrors.noncritical e ->
     Constrextern.set_extern_reference orig_extern_ref;
     str "??"
 
@@ -262,16 +260,19 @@ let pr_var_decl_skel pr_id env sigma (id,c,typ) =
   let ptyp = (str" : " ++ pt) in
   (pr_id id ++ hov 0 (pbody ++ ptyp))
 
-let pr_var_decl env sigma (id,c,typ) =
-  pr_var_decl_skel pr_id env sigma (id,c,typ)
+let pr_var_decl env sigma d =
+  pr_var_decl_skel pr_id env sigma (Context.Named.Declaration.to_tuple d)
 
 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 ->
+let pr_rel_decl env sigma decl =
+  let open Context.Rel.Declaration in
+  let na = get_name decl in
+  let typ = get_type decl in
+  let pbody = match decl with
+    | LocalAssum _ -> mt ()
+    | LocalDef (_,c,_) ->
 	(* Force evaluation *)
 	let pb = pr_lconstr_env env sigma c in
 	let pb = if isCast c then surround pb else pb in
@@ -293,7 +294,7 @@ let pr_named_context_of env sigma =
   hv 0 (prlist_with_sep (fun _ -> ws 2) (fun x -> x) psl)
 
 let pr_named_context env sigma ne_context =
-  hv 0 (Context.fold_named_context
+  hv 0 (Context.Named.fold_outside
 	  (fun d pps -> pps ++ ws 2 ++ pr_var_decl env sigma d)
           ne_context ~init:(mt ()))
 
@@ -306,7 +307,7 @@ let pr_rel_context_of env sigma =
 (* Prints an env (variables and de Bruijn). Separator: newline *)
 let pr_context_unlimited env sigma =
   let sign_env =
-    Context.fold_named_list_context
+    Context.NamedList.fold
       (fun d pps ->
          let pidt =  pr_var_list_decl env sigma d in
          (pps ++ fnl () ++ pidt))
@@ -333,7 +334,7 @@ let pr_context_limit n env sigma =
   else
     let k = lgsign-n in
     let _,sign_env =
-      Context.fold_named_list_context
+      Context.NamedList.fold
         (fun d (i,pps) ->
            if i < k then
 	     (i+1, (pps ++str "."))
@@ -380,16 +381,12 @@ let pr_transparent_state (ids, csts) =
 let default_pr_goal gs =
   let (g,sigma) = Goal.V82.nf_evar (project gs) (sig_it gs) in
   let env = Goal.V82.env sigma g in
-  let preamb,thesis,penv,pc =
-    mt (), mt (),
-    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)
+  let concl = Goal.V82.concl sigma g in
+  let goal =
+    pr_context_of env sigma ++ cut () ++
+      str "============================" ++ cut ()  ++
+      pr_goal_concl_style_env env sigma concl in
+  str "  " ++ v 0 goal
 
 (* display a goal tag *)
 let pr_goal_tag g =
@@ -400,7 +397,7 @@ 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))
+  if display_name then str " " ++ Pp.surround (pr_existential_key sigma g)
   else mt ()
 
 (* display the conclusion of a goal *)
@@ -420,13 +417,23 @@ let pr_evgl_sign sigma evi =
   | None -> [], []
   | Some f -> List.filter2 (fun b c -> not b) f (evar_context evi)
   in
-  let ids = List.rev_map pi1 l in
+  let open Context.Named.Declaration in
+  let ids = List.rev_map get_id l in
   let warn =
     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_env env sigma evi.evar_concl in
-  hov 0 (str"[" ++ ps ++ spc () ++ str"|- "  ++ pc ++ str"]" ++ spc () ++ warn)
+  let candidates =
+    match evi.evar_body, evi.evar_candidates with
+    | Evar_empty, Some l ->
+       spc () ++ str "= {" ++
+         prlist_with_sep (fun () -> str "|") (pr_lconstr_env env sigma) l ++ str "}"
+    | _ ->
+       mt ()
+  in
+  hov 0 (str"[" ++ ps ++ spc () ++ str"|- "  ++ pc ++ str"]" ++
+           candidates ++ spc () ++ warn)
 
 (* Print an existential variable *)
 
@@ -473,25 +480,91 @@ let default_pr_subgoal n sigma =
 
 let pr_internal_existential_key ev = str (string_of_existential ev)
 
-let emacs_print_dependent_evars sigma seeds =
+let print_evar_constraints gl sigma =
+  let pr_env =
+    match gl with
+    | None -> fun e' -> pr_context_of e' sigma
+    | Some g ->
+       let env = Goal.V82.env sigma g in fun e' ->
+       begin
+         if Context.Named.equal (named_context env) (named_context e') then
+           if Context.Rel.equal (rel_context env) (rel_context e') then mt ()
+           else pr_rel_context_of e' sigma ++ str " |-" ++ spc ()
+         else pr_context_of e' sigma ++ str " |-" ++ spc ()
+       end
+  in
+  let pr_evconstr (pbty,env,t1,t2) =
+    let t1 = Evarutil.nf_evar sigma t1
+    and t2 = Evarutil.nf_evar sigma t2 in
+    let env =
+      (** We currently allow evar instances to refer to anonymous de Bruijn
+          indices, so we protect the error printing code in this case by giving
+          names to every de Bruijn variable in the rel_context of the conversion
+          problem. MS: we should rather stop depending on anonymous variables, they
+          can be used to indicate independency. Also, this depends on a strategy for 
+          naming/renaming *)
+      Namegen.make_all_name_different env in
+    str" " ++
+      hov 2 (pr_env env ++ pr_lconstr_env env sigma t1 ++ spc () ++
+             str (match pbty with
+                  | Reduction.CONV -> "=="
+                  | Reduction.CUMUL -> "<=") ++
+             spc () ++ pr_lconstr_env env sigma t2)
+  in
+  let pr_candidate ev evi (candidates,acc) =
+    if Option.has_some evi.evar_candidates then
+      (succ candidates, acc ++ pr_evar sigma (ev,evi) ++ fnl ())
+    else (candidates, acc)
+  in
+  let constraints =
+    let _, cstrs = Evd.extract_all_conv_pbs sigma in
+    if List.is_empty cstrs then mt ()
+    else fnl () ++ str (String.plural (List.length cstrs) "unification constraint")
+         ++ str":" ++ fnl () ++ hov 0 (prlist_with_sep fnl pr_evconstr cstrs)
+  in
+  let candidates, ppcandidates = Evd.fold_undefined pr_candidate sigma (0,mt ()) in
+  constraints ++
+    if candidates > 0 then
+      fnl () ++ str (String.plural candidates "existential") ++
+        str" with candidates:" ++ fnl () ++ hov 0 ppcandidates
+    else mt ()
+
+let should_print_dependent_evars = ref false
+
+let _ =
+  let open Goptions in
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "Printing Dependent Evars Line";
+      optkey   = ["Printing";"Dependent";"Evars";"Line"];
+      optread  = (fun () -> !should_print_dependent_evars);
+      optwrite = (fun v -> should_print_dependent_evars := v) }
+
+let print_dependent_evars gl sigma seeds =
+  let constraints = print_evar_constraints gl sigma in
   let evars () =
-    let evars = Evarutil.gather_dependent_evars sigma seeds in
-    let evars =
-      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 " ++
-	    Evar.Set.fold begin fun d s ->
-	      pr_internal_existential_key d ++ str " " ++ s
-	    end i (str ",")
-      end evars (str "")
+    if !should_print_dependent_evars then
+      let evars = Evarutil.gather_dependent_evars sigma seeds in
+      let evars =
+	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 " ++
+	      Evar.Set.fold begin fun d s ->
+		pr_internal_existential_key d ++ str " " ++ s
+	      end i (str ",")
+	end evars (str "")
     in
     fnl () ++
     str "(dependent evars:" ++ evars ++ str ")" ++ fnl ()
+    else
+      fnl () ++
+	str "(dependent evars: (printing disabled) )" ++ fnl ()
   in
-  delayed_emacs_cmd evars
+  constraints ++ delayed_emacs_cmd evars
 
 (* Print open subgoals. Checks for uninstantiated existential variables *)
 (* spiwack: [seeds] is for printing dependent evars in emacs mode. *)
@@ -550,7 +623,7 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals
   (* Side effect! This has to be made more robust *)
   let () =
     match close_cmd with
-    | Some cmd -> msg_info cmd
+    | Some cmd -> Feedback.msg_info cmd
     | None -> ()
   in
   match goals with
@@ -559,12 +632,12 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals
 	let exl = Evarutil.non_instantiated sigma in
 	if Evar.Map.is_empty exl then
 	  (str"No more subgoals."
-	   ++ emacs_print_dependent_evars sigma seeds)
+	   ++ print_dependent_evars None sigma seeds)
 	else
 	  let pei = pr_evars_int sigma 1 exl in
 	  (str "No more subgoals, but there are non-instantiated existential variables:"
 	   ++ fnl () ++ (hov 0 pei)
-	   ++ emacs_print_dependent_evars sigma seeds ++ fnl () ++
+	   ++ print_dependent_evars None sigma seeds ++ fnl () ++
            str "You can use Grab Existential Variables.")
       end
   | [g] when not !Flags.print_emacs && pr_first ->
@@ -572,7 +645,7 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals
       v 0 (
 	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
+	++ print_dependent_evars (Some g) sigma seeds
       )
   | g1::rest ->
       let goals = print_multiple_goals g1 rest in
@@ -584,7 +657,7 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals
         ++ pr_goal_tag g1
         ++ pr_goal_name sigma g1 ++ cut ()
 	++ goals
-	++ emacs_print_dependent_evars sigma seeds
+	++ print_dependent_evars (Some g1) sigma seeds
       )
 
 (**********************************************************************)
@@ -628,19 +701,19 @@ let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () =
           begin match bgoals,shelf,given_up with
 	  | [] , [] , [] -> pr_subgoals None sigma seeds shelf stack goals
           | [] , [] , _ ->
-	     msg_info (str "No more subgoals, but there are some goals you gave up:");
+	     Feedback.msg_info (str "No more subgoals, but there are some goals you gave up:");
 	     fnl ()
             ++ pr_subgoals ~pr_first:false None bsigma seeds [] [] given_up
             ++ fnl () ++ str "You need to go back and solve them."
           | [] , _ , _ ->
-	    msg_info (str "All the remaining goals are on the shelf.");
+	    Feedback.msg_info (str "All the remaining goals are on the shelf.");
 	    fnl ()
             ++ pr_subgoals ~pr_first:false None bsigma seeds [] [] shelf
 	  | _ , _, _ ->
             let end_cmd =
               str "This subproof is complete, but there are some unfocused goals." ++
-	      (match Proof_global.Bullet.suggest p
-              with None  -> str"" | Some s -> fnl () ++ str s) ++
+              (let s = Proof_global.Bullet.suggest p in
+               if Pp.is_empty s then s else fnl () ++ s) ++
               fnl ()
             in
 	    pr_subgoals ~pr_first:false (Some end_cmd) bsigma seeds shelf [] bgoals
@@ -684,38 +757,10 @@ let pr_prim_rule = function
        (str"cut " ++ pr_constr t ++
         str ";[" ++ cl ++ str"intro " ++ pr_id id ++ str"|idtac]")
 
-  | FixRule (f,n,[],_) ->
-      (str"fix " ++ pr_id f ++ str"/" ++ int n)
-
-  | FixRule (f,n,others,j) ->
-      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
-        | [] -> mt () in
-      (str"fix " ++ pr_id f ++ str"/" ++ int n ++
-         str" with " ++ print_mut others)
-
-  | Cofix (f,[],_) ->
-      (str"cofix " ++ pr_id f)
-
-  | Cofix (f,others,j) ->
-      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)
-        | [] -> mt () in
-      (str"cofix " ++ pr_id f ++  str" with " ++ print_mut others)
   | Refine c ->
       str(if Termops.occur_meta c then "refine " else "exact ") ++
       Constrextern.with_meta_as_hole pr_constr c
 
-  | Thin ids ->
-      (str"clear "  ++ pr_sequence pr_id ids)
-
-  | Move (id1,id2) ->
-      (str"move "  ++ pr_id id1 ++ Miscprint.pr_move_location pr_id id2)
-
 (* Backwards compatibility *)
 
 let prterm = pr_lconstr
@@ -724,9 +769,14 @@ let prterm = pr_lconstr
 (* Printer function for sets of Assumptions.assumptions.
    It is used primarily by the Print Assumptions command. *)
 
+type axiom =
+  | Constant of constant (* An axiom or a constant. *)
+  | Positive of MutInd.t (* A mutually inductive definition which has been assumed positive. *)
+  | Guarded of constant (* a constant whose (co)fixpoints have been assumed to be guarded *)
+
 type context_object =
   | Variable of Id.t (* A section variable or a Let definition *)
-  | Axiom of constant * (Label.t * Context.rel_context * types) list
+  | Axiom of axiom * (Label.t * Context.Rel.t * types) list
   | Opaque of constant     (* An opaque constant. *)
   | Transparent of constant
 
@@ -734,19 +784,31 @@ type context_object =
 module OrderedContextObject =
 struct
   type t = context_object
+
+  let compare_axiom x y =
+    match x,y with
+    | Constant k1 , Constant k2 ->
+        con_ord k1 k2
+    | Positive m1 , Positive m2 ->
+        MutInd.CanOrd.compare m1 m2
+    | Guarded k1 , Guarded k2 ->
+        con_ord k1 k2
+    | _ , Constant _ -> 1
+    | _ , Positive _ -> 1
+    | _ -> -1
+
   let compare x y =
-      match x , y with
-      | 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 _ , Variable _
-      | Opaque _ , Axiom _ -> 1
-      | Transparent _ , Variable _
-      | Transparent _ , Axiom _
-      | Transparent _ , Opaque _ -> 1
-      | _ , _ -> -1
+    match x , y with
+    | Variable i1 , Variable i2 -> Id.compare i1 i2
+    | Variable _ , _ -> -1
+    | _ , Variable _ -> 1
+    | Axiom (k1,_) , Axiom (k2, _) -> compare_axiom k1 k2
+    | Axiom _ , _ -> -1
+    | _ , Axiom _ -> 1
+    | Opaque k1 , Opaque k2 -> con_ord k1 k2
+    | Opaque _ , _ -> -1
+    | _ , Opaque _ -> 1
+    | Transparent k1 , Transparent k2 -> con_ord k1 k2
 end
 
 module ContextObjectSet = Set.Make (OrderedContextObject)
@@ -754,7 +816,7 @@ module ContextObjectMap = Map.Make (OrderedContextObject)
 
 let pr_assumptionset env s =
   if ContextObjectMap.is_empty s &&
-       engagement env = (PredicativeSet, StratifiedType) then
+       engagement env = PredicativeSet then
     str "Closed under the global context"
   else
     let safe_pr_constant env kn =
@@ -765,28 +827,37 @@ let pr_assumptionset env s =
     in
     let safe_pr_ltype typ =
       try str " : " ++ pr_ltype typ
-      with e when Errors.noncritical e -> mt ()
+      with e when CErrors.noncritical e -> mt ()
     in
     let safe_pr_ltype_relctx (rctx, typ) =
       let sigma, env = get_current_context () in
       let env = Environ.push_rel_context rctx env in
       try str " " ++ pr_ltype_env env sigma typ
-      with e when Errors.noncritical e -> mt ()
+      with e when CErrors.noncritical e -> mt ()
+    in
+    let pr_axiom env ax typ =
+      match ax with
+      | Constant kn ->
+          safe_pr_constant env kn ++ safe_pr_ltype typ
+      | Positive m ->
+          hov 2 (MutInd.print m ++ spc () ++ strbrk"is positive.")
+      | Guarded kn ->
+          hov 2 (safe_pr_constant env kn ++ spc () ++ strbrk"is positive.")
     in
     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
+        let var = pr_id 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
+      | Axiom (axiom, []) ->
+        let ax = pr_axiom env axiom typ in
         (v, ax :: a, o, tr)
-      | Axiom (kn,l) ->
-        let ax = safe_pr_constant env kn ++ safe_pr_ltype typ ++
+      | Axiom (axiom,l) ->
+        let ax = pr_axiom env axiom typ ++
           cut() ++
           prlist_with_sep cut (fun (lbl, ctx, ty) ->
-            str " used in " ++ str (Names.Label.to_string lbl) ++
+            str " used in " ++ pr_label lbl ++
             str " to prove:" ++ safe_pr_ltype_relctx (ctx,ty))
           l in
         (v, ax :: a, o, tr)
@@ -839,4 +910,3 @@ let pr_polymorphic b =
 let pr_universe_instance evd ctx =
   let inst = Univ.UContext.instance ctx in
     str"@{" ++ Univ.Instance.pr (Evd.pr_evd_level evd) inst ++ str"}"
-
diff --git a/printing/printer.mli b/printing/printer.mli
index 3424c41d..695ab33b 100644
--- a/printing/printer.mli
+++ b/printing/printer.mli
@@ -10,7 +10,6 @@ open Pp
 open Names
 open Globnames
 open Term
-open Context
 open Environ
 open Pattern
 open Evd
@@ -109,13 +108,13 @@ val pr_pconstructor        : env -> pconstructor -> 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 -> 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_var_decl            : env -> evar_map -> Context.Named.Declaration.t -> std_ppcmds
+val pr_var_list_decl       : env -> evar_map -> Context.NamedList.Declaration.t -> std_ppcmds
+val pr_rel_decl            : env -> evar_map -> Context.Rel.Declaration.t -> std_ppcmds
 
-val pr_named_context       : env -> evar_map -> named_context -> std_ppcmds
+val pr_named_context       : env -> evar_map -> Context.Named.t -> 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         : env -> evar_map -> Context.Rel.t -> std_ppcmds
 val pr_rel_context_of      : env -> evar_map -> std_ppcmds
 val pr_context_of          : env -> evar_map -> std_ppcmds
 
@@ -162,12 +161,16 @@ val prterm                 : constr -> std_ppcmds (** = pr_lconstr *)
 
 
 (** Declarations for the "Print Assumption" command *)
+type axiom =
+  | Constant of constant (* An axiom or a constant. *)
+  | Positive of MutInd.t (* A mutually inductive definition which has been assumed positive. *)
+  | Guarded of constant (* a constant whose (co)fixpoints have been assumed to be guarded *)
+
 type context_object =
-  | Variable of Id.t  (** A section variable or a Let definition *)
-  (** An axiom and the type it inhabits (if an axiom of the empty type) *)
-  | Axiom of constant * (Label.t * Context.rel_context * types) list
-  | Opaque of constant      (** An opaque constant. *)
-  | Transparent of constant (** A transparent constant *)
+  | Variable of Id.t (* A section variable or a Let definition *)
+  | Axiom of axiom * (Label.t * Context.Rel.t * types) list
+  | Opaque of constant     (* An opaque constant. *)
+  | Transparent of constant
 
 module ContextObjectSet : Set.S with type elt = context_object
 module ContextObjectMap : CMap.ExtS
diff --git a/printing/printing.mllib b/printing/printing.mllib
index 652a34fa..bc8f0750 100644
--- a/printing/printing.mllib
+++ b/printing/printing.mllib
@@ -2,12 +2,8 @@ Genprint
 Pputils
 Ppannotation
 Ppconstr
-Ppconstrsig
 Printer
 Pptactic
-Pptacticsig
 Printmod
 Prettyp
 Ppvernac
-Ppvernacsig
-Richprinter
diff --git a/printing/printmod.ml b/printing/printmod.ml
index c154b0aa..dfa66d43 100644
--- a/printing/printmod.ml
+++ b/printing/printmod.ml
@@ -65,7 +65,6 @@ let get_new_id locals id =
 
 (** Inductive declarations *)
 
-open Termops
 open Reduction
 
 let print_params env sigma params =
@@ -89,7 +88,7 @@ let print_one_inductive env sigma mib ((_,i) as ind) =
     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 args = Context.Rel.to_extended_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
@@ -143,7 +142,7 @@ let print_record env mind mib =
   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 args = Context.Rel.to_extended_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
@@ -248,22 +247,27 @@ let get_typ_expr_alg mtb = match mtb.mod_type_alg with
   | _ -> raise Not_found
 
 let nametab_register_modparam mbid mtb =
+  let id = MBId.to_id mbid in
   match mtb.mod_type with
-  | MoreFunctor _ -> () (* functorial param : nothing to register *)
+  | MoreFunctor _ -> id (* 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 ->
+      let () = Declaremods.process_module_binding mbid (get_typ_expr_alg mtb) in
+      id
+    with e when CErrors.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
+      let check id = Nametab.exists_dir (DirPath.make [id]) in
+      let id = Namegen.next_ident_away_from id check in
+      let dir = DirPath.make [id] in
       nametab_register_dir mp;
-      List.iter (nametab_register_body mp dir) struc
+      List.iter (nametab_register_body mp dir) struc;
+      id
 
 let print_body is_impl env mp (l,body) =
-  let name = str (Label.to_string l) in
+  let name = pr_label l in
   hov 2 (match body with
     | SFBmodule _ -> keyword "Module" ++ spc () ++ name
     | SFBmodtype _ -> keyword "Module Type" ++ spc () ++ name
@@ -296,7 +300,7 @@ let print_body is_impl env mp (l,body) =
       try
 	let env = Option.get env in
 	pr_mutual_inductive_body env (MutInd.make2 mp l) mib
-      with e when Errors.noncritical e ->
+      with e when CErrors.noncritical e ->
         let keyword =
           let open Decl_kinds in
           match mib.mind_finite with
@@ -354,7 +358,7 @@ let print_mod_expr env mp locals = function
 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 id = nametab_register_modparam mbid mtb1 in
       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
@@ -362,7 +366,7 @@ let rec print_functor fty fatom is_type env mp locals = function
       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 ")" ++
+	 str "(" ++ pr_id id ++ str ":" ++ pr_mtb1 ++ str ")" ++
 	 spc() ++ print_functor fty fatom is_type env' mp locals' me2)
 
 let rec print_expression x =
@@ -423,7 +427,7 @@ let print_module with_body mp =
   try
     if !short then raise ShortPrinting;
     unsafe_print_module (Some (Global.env ())) mp with_body me ++ fnl ()
-  with e when Errors.noncritical e ->
+  with e when CErrors.noncritical e ->
     unsafe_print_module None mp with_body me ++ fnl ()
 
 let print_modtype kn =
@@ -434,7 +438,7 @@ let print_modtype kn =
      (try
 	if !short then raise ShortPrinting;
 	print_signature' true (Some (Global.env ())) kn mtb.mod_type
-      with e when Errors.noncritical e ->
+      with e when CErrors.noncritical e ->
 	print_signature' true None kn mtb.mod_type))
 
 end
diff --git a/proofs/clenv.ml b/proofs/clenv.ml
index 88e1bce9..0a90e0db 100644
--- a/proofs/clenv.ml
+++ b/proofs/clenv.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
@@ -24,6 +24,7 @@ open Pretype_errors
 open Evarutil
 open Unification
 open Misctypes
+open Sigma.Notations
 
 (* Abbreviations *)
 
@@ -71,7 +72,7 @@ let clenv_get_type_of ce c = Retyping.get_type_of (cl_env ce) (cl_sigma ce) c
 exception NotExtensibleClause
 
 let clenv_push_prod cl =
-  let typ = whd_betadeltaiota (cl_env cl) (cl_sigma cl) (clenv_type cl) in
+  let typ = whd_all (cl_env cl) (cl_sigma cl) (clenv_type cl) in
   let rec clrec typ = match kind_of_term typ with
     | Cast (t,_,_) -> clrec t
     | Prod (na,t,u) ->
@@ -108,7 +109,7 @@ let clenv_environments evd bound t =
       | (n, Cast (t,_,_)) -> clrec (e,metas) n t
       | (n, Prod (na,t1,t2)) ->
 	  let mv = new_meta () in
-	  let dep = dependent (mkRel 1) t2 in
+	  let dep = not (noccurn 1 t2) in
 	  let na' = if dep then na else Anonymous in
 	  let e' = meta_declare mv t1 ~name:na' e in
 	  clrec (e', (mkMeta mv)::metas) (Option.map ((+) (-1)) n)
@@ -119,7 +120,7 @@ let clenv_environments evd bound t =
   clrec (evd,[]) bound t
 
 let mk_clenv_from_env env sigma n (c,cty) =
-  let evd = create_goal_evar_defs sigma in
+  let evd = clear_metas sigma in
   let (evd,args,concl) = clenv_environments evd n cty in
   { templval = mk_freelisted (applist (c,args));
     templtyp = mk_freelisted concl;
@@ -335,22 +336,15 @@ let clenv_pose_metas_as_evars clenv dep_mvs =
       else
         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 evd = Sigma.Unsafe.of_evar_map clenv.evd in
+	let Sigma (evar, evd, _) = new_evar (cl_env clenv) evd ~src ty in
+	let evd = Sigma.to_evar_map evd in
 	let clenv = clenv_assign mv evar {clenv with evd=evd} in
 	fold clenv mvs in
   fold clenv dep_mvs
 
 (******************************************************************)
 
-let connect_clenv gls clenv =
-  let evd = evars_reset_evd ~with_conv_pbs:true gls.sigma clenv.evd in
-  { clenv with
-    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
@@ -432,6 +426,44 @@ let check_bindings bl =
 	   str " occurs more than once in binding list.")
     | [] -> ()
 
+let explain_no_such_bound_variable evd id =
+  let fold l (n, clb) =
+    let na = match clb with
+    | Cltyp (na, _) -> na
+    | Clval (na, _, _) -> na
+    in
+    if na != Anonymous then out_name na :: l else l
+  in
+  let mvl = List.fold_left fold [] (Evd.meta_list evd) 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 fold (l1, l2 as l) (n, clb) =
+    let (na',def) = match clb with
+    | Cltyp (na, _) -> (na, false)
+    | Clval (na, _, _) -> (na, true)
+    in
+    if Name.equal na na' then if def then (n::l1,l2) else (n::l1,n::l2)
+    else l
+  in
+  let (mvl, mvnodef) = List.fold_left fold ([], []) (Evd.meta_list evd) in
+  match mvnodef, mvl with
+    | _,[]  ->
+      explain_no_such_bound_variable evd id
+    | ([n],_|_,[n]) ->
+        n
+    | _  ->
+        errorlabstrm "Evd.meta_with_name"
+          (str "Binder name \"" ++ pr_id id ++
+           strbrk "\" occurs more than once in clause.")
+
 let meta_of_binder clause loc mvs = function
   | NamedHyp s -> meta_with_name clause.evd s
   | AnonHyp n ->
@@ -459,7 +491,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 (_,_,ActualTypeNotCoercible (_,_,NotClean _)) as e ->
+      | PretypeError (_,_,ActualTypeNotCoercible (_,_,
+          (NotClean _ | ConversionFailed _))) as e ->
 	  raise e
       | e when precatchable_exception e ->
 	  TypeNotProcessed, clenv, c
@@ -576,7 +609,9 @@ let make_evar_clause env sigma ?len t =
     | 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 sigma = Sigma.Unsafe.of_evar_map sigma in
+      let Sigma (ev, sigma, _) = new_evar ~store env sigma t1 in
+      let sigma = Sigma.to_evar_map sigma in
       let dep = dependent (mkRel 1) t2 in
       let hole = {
         hole_evar = ev;
@@ -628,7 +663,7 @@ let evar_of_binder holes = function
   try
     let h = List.nth holes (pred n) in
     h.hole_evar
-  with e when Errors.noncritical e ->
+  with e when CErrors.noncritical e ->
     errorlabstrm "" (str "No such binder.")
 
 let define_with_type sigma env ev c =
diff --git a/proofs/clenv.mli b/proofs/clenv.mli
index 7ecc26ec..e9236b1d 100644
--- a/proofs/clenv.mli
+++ b/proofs/clenv.mli
@@ -6,6 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(** This file defines clausenv, which is a deprecated way to handle open terms
+    in the proof engine. Most of the API here is legacy except for the
+    evar-based clauses. *)
+
 open Names
 open Term
 open Environ
@@ -49,7 +53,6 @@ val refresh_undefined_univs : clausenv -> clausenv * Univ.universe_level_subst
 
 (** {6 linking of clenvs } *)
 
-val connect_clenv : Goal.goal sigma -> clausenv -> clausenv
 val clenv_fchain :
   ?with_univs:bool -> ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv
 
diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml
index 8e922599..98b5bc8b 100644
--- a/proofs/clenvtac.ml
+++ b/proofs/clenvtac.ml
@@ -16,7 +16,7 @@ open Logic
 open Reduction
 open Tacmach
 open Clenv
-
+open Proofview.Notations
 
 (* This function put casts around metavariables whose type could not be
  * infered by the refiner, that is head of applications, predicates and
@@ -59,6 +59,19 @@ let clenv_pose_dependent_evars with_evars clenv =
       (RefinerError (UnresolvedBindings (List.map (meta_name clenv.evd) dep_mvs)));
   clenv_pose_metas_as_evars clenv dep_mvs
 
+(** Use our own fast path, more informative than from Typeclasses *)
+let check_tc evd =
+  let has_resolvable = ref false in
+  let check _ evi =
+    let res = Typeclasses.is_resolvable evi in
+    if res then
+      let () = has_resolvable := true in
+      Typeclasses.is_class_evar evd evi
+    else false
+  in
+  let has_typeclass = Evar.Map.exists check (Evd.undefined_map evd) in
+  (has_typeclass, !has_resolvable)
+
 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
@@ -67,9 +80,16 @@ let clenv_refine with_evars ?(with_classes=true) clenv =
   let clenv = clenv_pose_dependent_evars with_evars clenv in
   let evd' =
     if with_classes then
-      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'
+      let (has_typeclass, has_resolvable) = check_tc clenv.evd in
+      let evd' =
+        if has_typeclass then
+          Typeclasses.resolve_typeclasses ~fast_path:false ~filter:Typeclasses.all_evars
+          ~fail:(not with_evars) clenv.env clenv.evd
+        else clenv.evd
+      in
+      if has_resolvable then
+        Typeclasses.mark_unresolvables ~filter:Typeclasses.all_goals evd'
+      else evd'
     else clenv.evd
   in
   let clenv = { clenv with evd = evd' } in
@@ -83,10 +103,10 @@ open Unification
 let dft = default_unify_flags
 
 let res_pf ?(with_evars=false) ?(with_classes=true) ?(flags=dft ()) clenv =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { 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
+  end }
 
 (* [unifyTerms] et [unify] ne semble pas gérer les Meta, en
    particulier ne semblent pas vérifier que des instances différentes
@@ -118,12 +138,12 @@ let fail_quick_unif_flags = {
 
 (* 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 ->
+  Proofview.Goal.enter { 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
+    let n = Tacmach.New.pf_concl (Proofview.Goal.assume gl) in
+    let evd = clear_metas (Tacmach.New.project gl) in
     try
       let evd' = w_unify env evd CONV ~flags m n in
 	Proofview.Unsafe.tclEVARSADVANCE evd'
-    with e when Errors.noncritical e -> Proofview.tclZERO e
-  end
+    with e when CErrors.noncritical e -> Proofview.tclZERO e
+  end }
diff --git a/proofs/clenvtac.mli b/proofs/clenvtac.mli
index 00e74a24..aa091aec 100644
--- a/proofs/clenvtac.mli
+++ b/proofs/clenvtac.mli
@@ -6,6 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(** Legacy components of the previous proof engine. *)
+
 open Term
 open Clenv
 open Tacexpr
diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml
index 059ae54c..29cad063 100644
--- a/proofs/evar_refiner.ml
+++ b/proofs/evar_refiner.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Evd
@@ -46,27 +46,16 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma =
   let sigma',typed_c =
     let flags = {
       Pretyping.use_typeclasses = true;
-      Pretyping.use_unif_heuristics = true;
+      Pretyping.solve_unification_constraints = 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 ->
+    with e when CErrors.noncritical e ->
       let loc = Glob_ops.loc_of_glob_constr rawc in
       user_err_loc
         (loc,"", str "Instance is not well-typed in the environment of " ++
-                 str (string_of_existential evk))
+                 pr_existential_key sigma evk ++ str ".")
   in
   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_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 35a3e5d8..e3778e94 100644
--- a/proofs/evar_refiner.mli
+++ b/proofs/evar_refiner.mli
@@ -13,8 +13,3 @@ open Pretyping
 
 val w_refine : evar * evar_info ->
   glob_constr_ltac_closure -> evar_map -> evar_map
-
-val instantiate_pf_com :
-  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 1dd5be0e..111a947a 100644
--- a/proofs/goal.ml
+++ b/proofs/goal.ml
@@ -9,6 +9,8 @@
 open Util
 open Pp
 open Term
+open Sigma.Notations
+open Context.Named.Declaration
 
 (* This module implements the abstract interface to goals *)
 (* A general invariant of the module, is that a goal whose associated
@@ -70,10 +72,12 @@ module V82 = struct
 		Evd.evar_extra = extra }
     in
     let evi = Typeclasses.mark_unresolvable evi in
-    let (evars, evk) = Evarutil.new_pure_evar_full evars evi in
+    let evars = Sigma.Unsafe.of_evar_map evars in
+    let Sigma (evk, evars, _) = Evarutil.new_pure_evar_full evars evi in
+    let evars = Sigma.to_evar_map evars 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 inst = Array.map_of_list (mkVar % get_id) ctxt in
     let ev = Term.mkEvar (evk,inst) in
     (evk, ev, evars)
 
@@ -89,7 +93,10 @@ module V82 = struct
   (* 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)
+    let sigma = partial_solution sigma evk c in
+    match id with
+    | None -> sigma
+    | Some id -> Evd.rename evk' id sigma
 
   (* Parts of the progress tactical *)
   let same_goal evars1 gl1 evars2 gl2 =
@@ -123,8 +130,10 @@ module V82 = struct
     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 (new_sigma, evk) = Evarutil.new_pure_evar_full Evd.empty new_evi in
-    { Evd.it = evk ; sigma = new_sigma; }
+    let sigma = Sigma.Unsafe.of_evar_map Evd.empty in
+    let Sigma (evk, sigma, _) = Evarutil.new_pure_evar_full sigma new_evi in
+    let sigma = Sigma.to_evar_map sigma in
+    { Evd.it = evk ; sigma = sigma; }
 
   (* Used by the compatibility layer and typeclasses *)
   let nf_evar sigma gl =
@@ -139,7 +148,7 @@ module V82 = struct
     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
+      try ignore (Environ.lookup_named (get_id 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 6152826c..6a79c1f4 100644
--- a/proofs/goal.mli
+++ b/proofs/goal.mli
@@ -6,7 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* This module implements the abstract interface to goals *)
+(** This module implements the abstract interface to goals. Most of the code
+    here is useless and should be eventually removed. Consider using
+    {!Proofview.Goal} instead. *)
 
 type goal = Evar.t
 
@@ -67,7 +69,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 -> Context.named_context -> goal Evd.sigma
+  val new_goal_with : Evd.evar_map -> goal -> Context.Named.t -> 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 ed3a1df1..65497c80 100644
--- a/proofs/logic.ml
+++ b/proofs/logic.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
@@ -22,6 +22,7 @@ open Proof_type
 open Type_errors
 open Retyping
 open Misctypes
+open Context.Named.Declaration
 
 type refiner_error =
 
@@ -58,7 +59,7 @@ let is_unification_error = function
 | _ -> false
 
 let catchable_exception = function
-  | Errors.UserError _ | TypeError _
+  | CErrors.UserError _ | TypeError _
   | RefinerError _ | Indrec.RecursionSchemeError _
   | Nametab.GlobalizationError _
   (* reduction errors *)
@@ -76,10 +77,10 @@ let with_check = Flags.with_option check
 
 (* [apply_to_hyp sign id f] splits [sign] into [tail::[id,_,_]::head] and
    returns [tail::(f head (id,_,_) (rev tail))] *)
-let apply_to_hyp sign id f =
+let apply_to_hyp check sign id f =
   try apply_to_hyp sign id f
   with Hyp_not_found ->
-    if !check then error_no_such_hypothesis id
+    if check then error_no_such_hypothesis id
     else sign
 
 let check_typability env sigma c =
@@ -95,12 +96,12 @@ let check_typability env sigma c =
    forces the user to give them in order). *)
 
 let clear_hyps env sigma ids sign cl =
-  let evdref = ref (Evd.create_goal_evar_defs sigma) in
+  let evdref = ref (Evd.clear_metas sigma) in
   let (hyps,cl) = Evarutil.clear_hyps_in_evi env evdref sign cl ids in
   (hyps, cl, !evdref)
 
 let clear_hyps2 env sigma ids sign t cl =
-  let evdref = ref (Evd.create_goal_evar_defs sigma) in
+  let evdref = ref (Evd.clear_metas sigma) in
   let (hyps,t,cl) = Evarutil.clear_hyps2_in_evi env evdref sign t cl ids in
   (hyps, t, cl, !evdref)
 
@@ -160,7 +161,8 @@ let reorder_context env sign ord =
       | _ ->
           (match ctxt_head with
             | [] -> error_no_such_hypothesis (List.hd ord)
-            | (x,_,_ as d) :: ctxt ->
+            | d :: ctxt ->
+                let x = get_id d in
                 if Id.Set.mem x expected then
                   step ord (Id.Set.remove x expected)
                     ctxt (push_item x d moved_hyps) ctxt_tail
@@ -175,7 +177,8 @@ let reorder_val_context env sign ord =
 
 
 
-let check_decl_position env sign (x,_,_ as d) =
+let check_decl_position env sign d =
+  let x = get_id d in
   let needed = global_vars_set_of_decl env d in
   let deps = dependency_closure env (named_context_of_val sign) needed in
   if Id.List.mem x deps then
@@ -200,16 +203,17 @@ let move_location_eq m1 m2 = match m1, m2 with
 
 let rec get_hyp_after h = function
   | [] -> error_no_such_hypothesis h
-  | (hyp,_,_) :: right ->
-      if Id.equal hyp h then
-	match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveFirst
+  | d :: right ->
+      if Id.equal (get_id d) h then
+	match right with d' ::_ -> MoveBefore (get_id d') | [] -> MoveFirst
       else
        get_hyp_after h right
 
 let split_sign hfrom hto l =
   let rec splitrec left toleft = function
     | [] -> error_no_such_hypothesis hfrom
-    | (hyp,c,typ) as d :: right ->
+    | d :: right ->
+        let hyp,_,typ = to_tuple d in
       	if Id.equal hyp hfrom then
 	  (left,right,d, toleft || move_location_eq hto MoveLast)
       	else
@@ -227,27 +231,28 @@ let hyp_of_move_location = function
   | MoveBefore id -> id
   | _ -> assert false
 
-let move_hyp toleft (left,(idfrom,_,_ as declfrom),right) hto =
+let move_hyp toleft (left,declfrom,right) hto =
   let env = Global.env() in
-  let test_dep (hyp,c,typ as d) (hyp2,c,typ2 as d2) =
+  let test_dep d d2 =
     if toleft
-    then occur_var_in_decl env hyp2 d
-    else occur_var_in_decl env hyp d2
+    then occur_var_in_decl env (get_id d2) d
+    else occur_var_in_decl env (get_id d) d2
   in
   let rec moverec first middle = function
     | [] ->
 	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 move_location_eq hto (MoveBefore hyp) ->
+    | d :: _ as right when move_location_eq hto (MoveBefore (get_id d)) ->
 	List.rev first @ List.rev middle @ right
-    | (hyp,_,_) as d :: right ->
+    | d :: right ->
+        let hyp = get_id d in
 	let (first',middle') =
       	  if List.exists (test_dep d) middle then
 	    if not (move_location_eq hto (MoveAfter hyp)) then
 	      (first, d::middle)
             else
-	      errorlabstrm "move_hyp" (str "Cannot move " ++ pr_id idfrom ++
+	      errorlabstrm "move_hyp" (str "Cannot move " ++ pr_id (get_id declfrom) ++
 	        Miscprint.pr_move_location pr_id hto ++
 	        str (if toleft then ": it occurs in " else ": it depends on ")
 	        ++ pr_id hyp ++ str ".")
@@ -271,6 +276,11 @@ let move_hyp toleft (left,(idfrom,_,_ as declfrom),right) hto =
     List.fold_left (fun sign d -> push_named_context_val d sign)
       right left
 
+let move_hyp_in_named_context hfrom hto sign =
+  let (left,right,declfrom,toleft) =
+    split_sign hfrom hto (named_context_of_val sign) in
+  move_hyp toleft (left,declfrom,right) hto
+
 (**********************************************************************)
 
 
@@ -458,7 +468,7 @@ and mk_hdgoals sigma goal goalacc trm =
 
 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 t = whd_all (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
@@ -483,12 +493,14 @@ and mk_casegoals sigma goal goalacc p c =
   (acc'',lbrty,conclty,sigma,p',c')
 
 
-let convert_hyp check sign sigma (id,b,bt as d) =
+let convert_hyp check sign sigma d =
+  let id,b,bt = to_tuple d in
   let env = Global.env() in
   let reorder = ref [] in
   let sign' =
-    apply_to_hyp sign id
-      (fun _ (_,c,ct) _ ->
+    apply_to_hyp check sign id
+      (fun _ d' _ ->
+        let _,c,ct = to_tuple d' in
         let env = Global.env_of_context sign in
         if check && not (is_conv env sigma bt ct) then
 	  errorlabstrm "Logic.convert_hyp"
@@ -522,126 +534,23 @@ let prim_refiner r sigma goal =
 	  if replace then
 	    let nexthyp = get_hyp_after id (named_context_of_val sign) in
 	    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)
+	    move_hyp false ([], LocalAssum (id,t),named_context_of_val sign)
 	      nexthyp,
 	      t,cl,sigma
 	  else
-            (if !check && mem_named_context id (named_context_of_val sign) then
+            (if !check && mem_named_context_val id sign then
 	      errorlabstrm "Logic.prim_refiner"
                 (str "Variable " ++ pr_id id ++ str " is already declared.");
-	     push_named_context_val (id,None,t) sign,t,cl,sigma) in
+	     push_named_context_val (LocalAssum (id,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 (mkNamedLambda id t ev2 , [| ev1 |]) in
+	let oterm = Term.mkNamedLetIn id ev1 t ev2 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 Int.equal k 1 then
-		  try
-		    fst (find_inductive env sigma c1)
-		  with Not_found ->
-		    error "Cannot do a fixpoint on a non inductive type."
-            	else
-		  check_ind (push_rel (na,None,c1) env) (k-1) b
-            | _ -> error "Not enough products."
-	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',_),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
-		errorlabstrm "Logic.prim_refiner"
-		  (str "Name " ++ pr_id f ++ str " already used in the environment");
-	      mk_sign (push_named_context_val (f,None,ar) sign) oth
-	  | [] ->
-	      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 (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
-	let bodies = Array.of_list evs in
-	let oterm = Term.mkFix ((indxs,0),(funnames,typarray,bodies)) in
-	let sigma = Goal.V82.partial_solution sigma goal oterm in
-	(gls,sigma)
-
-    | Cofix (f,others,j) ->
-     	let rec check_is_coind env cl =
-	  let b = whd_betadeltaiota env sigma cl in
-          match kind_of_term b with
-            | Prod (na,c1,b) -> check_is_coind (push_rel (na,None,c1) env) b
-            | _ ->
-		try
-		  let _ = find_coinductive env sigma b in ()
-                with Not_found ->
-		  error "All methods must construct elements in coinductive types."
-	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
-          | (f,ar)::oth ->
-	      (try
-                (let _ = lookup_named_val f sign in
-                error "Name already used in the environment.")
-              with
-              |	Not_found ->
-                  mk_sign (push_named_context_val (f,None,ar) sign) oth)
-	  | [] -> 
-              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 (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
-	let oterm = Term.mkCoFix (0,(funnames,typarray,bodies)) in
-	let sigma = Goal.V82.partial_solution sigma goal oterm in
-        (gls,sigma)
-
     | Refine c ->
 	check_meta_variables c;
 	let (sgl,cl',sigma,oterm) = mk_refgoals sigma goal [] cl c in
 	let sgl = List.rev sgl in
 	let sigma = Goal.V82.partial_solution sigma goal oterm in
 	  (sgl, sigma)
-
-    (* And now the structural rules *)
-    | Thin ids ->
-        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_to sigma goal gl ev in
-	  ([gl], sigma)
-
-    | Move (hfrom, hto) ->
-  	let (left,right,declfrom,toleft) =
-	  split_sign hfrom hto (named_context_of_val sign) in
-  	let hyps' =
-	  move_hyp toleft (left,declfrom,right) hto in
-	let (gl,ev,sigma) = mk_goal hyps' cl in
-	let sigma = Goal.V82.partial_solution_to sigma goal gl ev in
-  	  ([gl], sigma)
diff --git a/proofs/logic.mli b/proofs/logic.mli
index ed99d3a3..0dba9ef1 100644
--- a/proofs/logic.mli
+++ b/proofs/logic.mli
@@ -6,6 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(** Legacy proof engine. Do not use in newly written code. *)
+
 open Names
 open Term
 open Evd
@@ -53,4 +55,7 @@ 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
+  Context.Named.Declaration.t -> Environ.named_context_val
+
+val move_hyp_in_named_context : Id.t -> Id.t Misctypes.move_location ->
+  Environ.named_context_val -> Environ.named_context_val
diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml
index b635cc96..eddbf72a 100644
--- a/proofs/pfedit.ml
+++ b/proofs/pfedit.ml
@@ -13,6 +13,17 @@ open Entries
 open Environ
 open Evd
 
+let use_unification_heuristics_ref = ref true
+let _ = Goptions.declare_bool_option {
+  Goptions.optsync = true; Goptions.optdepr = false;
+  Goptions.optname = "Solve unification constraints at every \".\"";
+  Goptions.optkey = ["Solve";"Unification";"Constraints"];
+  Goptions.optread = (fun () -> !use_unification_heuristics_ref);
+  Goptions.optwrite = (fun a -> use_unification_heuristics_ref:=a);
+}
+
+let use_unification_heuristics () = !use_unification_heuristics_ref
+
 let refining = Proof_global.there_are_pending_proofs
 let check_no_pending_proofs = Proof_global.check_no_pending_proof
 
@@ -39,7 +50,7 @@ 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.")
+  | _ -> CErrors.anomaly ~label:"Pfedit.cook_proof" (Pp.str "more than one proof term.")
 
 let cook_proof () =
   cook_this_proof (fst
@@ -59,9 +70,9 @@ let get_universe_binders () =
   Proof_global.get_universe_binders ()
 
 exception NoSuchGoal
-let _ = Errors.register_handler begin function
-  | NoSuchGoal -> Errors.error "No such goal."
-  | _ -> raise Errors.Unhandled
+let _ = CErrors.register_handler begin function
+  | NoSuchGoal -> CErrors.error "No such goal."
+  | _ -> raise CErrors.Unhandled
 end
 let get_nth_V82_goal i =
   let p = Proof_global.give_me_the_proof () in
@@ -71,26 +82,38 @@ let get_nth_V82_goal i =
   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 -> Errors.error "No focused proof."
+  let { it=goal ; sigma=sigma; } =  get_nth_V82_goal i in
+  (sigma, Refiner.pf_env { it=goal ; sigma=sigma; })
 
 let get_goal_context i =
   try get_goal_context_gen i
-  with NoSuchGoal -> Errors.error "No such goal."
+  with Proof_global.NoCurrentProof -> CErrors.error "No focused proof."
+     | NoSuchGoal -> CErrors.error "No such goal."
 
 let get_current_goal_context () =
   try get_goal_context_gen 1
-  with NoSuchGoal ->
+  with Proof_global.NoCurrentProof -> CErrors.error "No focused proof."
+     | NoSuchGoal -> 
     (* spiwack: returning empty evar_map, since if there is no goal, under focus,
         there is no accessible evar either *)
-    (Evd.empty, Global.env ())
+    let env = Global.env () in
+    (Evd.from_env env, env)
+
+let get_current_context () =
+  try get_goal_context_gen 1
+  with Proof_global.NoCurrentProof ->
+    let env = Global.env () in
+    (Evd.from_env env, env)
+     | NoSuchGoal ->
+        (* No more focused goals ? *)
+        let p = get_pftreestate () in
+        let evd = Proof.in_proof p (fun x -> x) in
+        (evd, Global.env ())
 
 let current_proof_statement () =
   match Proof_global.V82.get_current_initial_conclusions () with
     | (id,([concl],strength)) -> id,strength,concl
-    | _ -> Errors.anomaly ~label:"Pfedit.current_proof_statement" (Pp.str "more than one statement")
+    | _ -> CErrors.anomaly ~label:"Pfedit.current_proof_statement" (Pp.str "more than one statement")
 
 let solve ?with_end_tac gi info_lvl tac pr =
   try 
@@ -103,24 +126,28 @@ let solve ?with_end_tac gi info_lvl tac pr =
     in
     let tac = match gi with
       | Vernacexpr.SelectNth i -> Proofview.tclFOCUS i i tac
+      | Vernacexpr.SelectList l -> Proofview.tclFOCUSLIST l tac
       | Vernacexpr.SelectId id -> Proofview.tclFOCUSID id tac
       | Vernacexpr.SelectAll -> tac
-      | Vernacexpr.SelectAllParallel ->
-          Errors.anomaly(str"SelectAllParallel not handled by Stm")
+    in
+    let tac =
+      if use_unification_heuristics () then
+        Proofview.tclTHEN tac Refine.solve_constraints
+      else tac
     in
     let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac pr in
     let () =
       match info_lvl with
       | None -> ()
-      | Some i -> Pp.msg_info (hov 0 (Proofview.Trace.pr_info ~lvl:i info))
+      | Some i -> Feedback.msg_info (hov 0 (Proofview.Trace.pr_info ~lvl:i info))
     in
     (p,status)
   with
-    | Proof_global.NoCurrentProof  -> Errors.error "No focused proof"
+    | Proof_global.NoCurrentProof  -> CErrors.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
+	                            CErrors.errorlabstrm "" msg
         | _ -> assert false
 
 let by tac = Proof_global.with_current_proof (fun _ -> solve (Vernacexpr.SelectNth 1) None tac)
@@ -138,22 +165,24 @@ let next = let n = ref 0 in fun () -> incr n; !n
 
 let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theorem) typ tac =
   let evd = Evd.from_ctx ctx in
-  start_proof id goal_kind evd sign typ (fun _ -> ());
+  let terminator = Proof_global.make_terminator (fun _ -> ()) in
+  start_proof id goal_kind evd sign typ terminator;
   try
     let status = by tac in
     let _,(const,univs,_) = cook_proof () in
     delete_current_proof ();
     const, status, fst univs
   with reraise ->
-    let reraise = Errors.push reraise in
+    let reraise = CErrors.push reraise in
     delete_current_proof ();
     iraise reraise
 
-let build_by_tactic ?(side_eff=true) env ctx ?(poly=false) typ tac =
+let build_by_tactic ?(side_eff=true) env sigma ?(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
   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, status, univs =
+    build_constant_by_tactic id sigma sign ~goal_kind:gk typ tac in
   let ce =
     if side_eff then Safe_typing.inline_private_constants_in_definition_entry env ce
     else { ce with
@@ -176,7 +205,7 @@ let refine_by_tactic env sigma ty tac =
     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
+      let (_, info) = CErrors.push src in
       iraise (e, info)
   in
   (** Plug back the retrieved sigma *)
@@ -203,7 +232,7 @@ let refine_by_tactic env sigma ty tac =
 (* Support for resolution of evars in tactic interpretation, including
    resolution by application of tactics *)
 
-let implicit_tactic = ref None
+let implicit_tactic = Summary.ref None ~name:"implicit-tactic"
 
 let declare_implicit_tactic tac = implicit_tactic := Some tac
 
@@ -214,12 +243,15 @@ let solve_by_implicit_tactic env sigma evk =
   match (!implicit_tactic, snd (evar_source evk sigma)) with
   | Some tac, (Evar_kinds.ImplicitArg _ | Evar_kinds.QuestionMark _)
       when
-	Context.named_context_equal (Environ.named_context_of_val evi.evar_hyps)
+	Context.Named.equal (Environ.named_context_of_val evi.evar_hyps)
 	(Environ.named_context env) ->
-      let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (Errors.UserError ("",Pp.str"Proof is not complete."))) []) in
+      let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (CErrors.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
+        let c = Evarutil.nf_evars_universes sigma evi.evar_concl in
+        if Evarutil.has_undefined_evars sigma c then raise Exit;
+        let (ans, _, ctx) =
+	  build_by_tactic env (Evd.evar_universe_context sigma) c tac in
+        let sigma = Evd.set_universe_context sigma ctx in
+        sigma, ans
        with e when Logic.catchable_exception e -> raise Exit)
   | _ -> raise Exit
diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli
index cd899201..ea604e08 100644
--- a/proofs/pfedit.mli
+++ b/proofs/pfedit.mli
@@ -6,6 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(** Global proof state. A quite redundant wrapper on {!Proof_global}. *)
+
 open Loc
 open Names
 open Term
@@ -93,6 +95,14 @@ val get_goal_context : int -> Evd.evar_map * env
 
 val get_current_goal_context : unit -> Evd.evar_map * env
 
+(** [get_current_context ()] returns the context of the
+  current focused goal. If there is no focused goal but there
+  is a proof in progress, it returns the corresponding evar_map.
+  If there is no pending proof then it returns the current global
+  environment and empty evar_map. *)
+
+val get_current_context : unit -> Evd.evar_map * env
+
 (** [current_proof_statement] *)
 
 val current_proof_statement :
@@ -157,7 +167,8 @@ val instantiate_nth_evar_com : int -> Constrexpr.constr_expr -> unit
 val build_constant_by_tactic :
   Id.t -> Evd.evar_universe_context -> named_context_val -> ?goal_kind:goal_kind ->
   types -> unit Proofview.tactic -> 
-  Safe_typing.private_constants Entries.definition_entry * bool * Evd.evar_universe_context
+  Safe_typing.private_constants Entries.definition_entry * bool *
+    Evd.evar_universe_context
 
 val build_by_tactic : ?side_eff:bool -> env -> Evd.evar_universe_context -> ?poly:polymorphic ->
   types -> unit Proofview.tactic -> 
@@ -179,5 +190,4 @@ val declare_implicit_tactic : unit Proofview.tactic -> unit
 val clear_implicit_tactic : unit -> unit
 
 (* Raise Exit if cannot solve *)
-(* FIXME: interface: it may incur some new universes etc... *)
-val solve_by_implicit_tactic : env -> Evd.evar_map -> Evd.evar -> constr
+val solve_by_implicit_tactic : env -> Evd.evar_map -> Evd.evar -> Evd.evar_map * constr
diff --git a/proofs/proof.ml b/proofs/proof.ml
index 0489305a..5c963d53 100644
--- a/proofs/proof.ml
+++ b/proofs/proof.ml
@@ -64,17 +64,17 @@ exception NoSuchGoals of int * int
 
 exception FullyUnfocused
 
-let _ = Errors.register_handler begin function
+let _ = CErrors.register_handler begin function
   | CannotUnfocusThisWay ->
-    Errors.error "This proof is focused, but cannot be unfocused this way"
+    CErrors.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").")
+      CErrors.errorlabstrm "Focus" Pp.(str"No such goal (" ++ int i ++ str").")
   | NoSuchGoals (i,j) ->
-      Errors.errorlabstrm "Focus" Pp.(
+      CErrors.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
+  | FullyUnfocused -> CErrors.error "The proof is not focused"
+  | _ -> raise CErrors.Unhandled
 end
 
 let check_cond_kind c k =
@@ -300,12 +300,12 @@ exception UnfinishedProof
 exception HasShelvedGoals
 exception HasGivenUpGoals
 exception HasUnresolvedEvar
-let _ = Errors.register_handler begin function
-  | 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
+let _ = CErrors.register_handler begin function
+  | UnfinishedProof -> CErrors.error "Some goals have not been solved."
+  | HasShelvedGoals -> CErrors.error "Some goals have been left on the shelf."
+  | HasGivenUpGoals -> CErrors.error "Some goals have been given up."
+  | HasUnresolvedEvar -> CErrors.error "Some existential variables are uninstantiated."
+  | _ -> raise CErrors.Unhandled
 end
 
 let return p =
@@ -334,21 +334,30 @@ let compact p =
 (*** Tactics ***)
 
 let run_tactic env tac pr =
+  let open Proofview.Notations in
   let sp = pr.proofview in
-  let (_,tacticced_proofview,(status,to_shelve,give_up),info_trace) =
+  let undef sigma l = List.filter (fun g -> Evd.is_undefined sigma g) l in
+  let tac =
+    tac >>= fun () ->
+    Proofview.tclEVARMAP >>= fun sigma ->
+    (* Already solved goals are not to be counted as shelved. Nor are
+      they to be marked as unresolvable. *)
+    let retrieved = undef sigma (List.rev (Evd.future_goals sigma)) in
+    let sigma = List.fold_left Proofview.Unsafe.mark_as_goal sigma retrieved in
+    Proofview.Unsafe.tclEVARS sigma >>= fun () ->
+    Proofview.tclUNIT retrieved
+  in
+  let (retrieved,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 sigma = Proofview.return proofview in
+  let to_shelve = undef sigma to_shelve in
+  let shelf = (undef sigma pr.shelf)@retrieved@to_shelve in
   let proofview =
     List.fold_left
-      Proofview.Unsafe.mark_as_goal
-      tacticced_proofview
-      retrieved
+      Proofview.Unsafe.mark_as_unresolvable
+      proofview
+      to_shelve
   in
   let given_up = pr.given_up@give_up in
   let proofview = Proofview.Unsafe.reset_future_goals proofview in
@@ -387,9 +396,27 @@ module V82 = struct
       { p with proofview = Proofview.V82.grab p.proofview }
 
 
+  (* Main component of vernac command Existential *)
   let instantiate_evar n com pr =
-    let sp = pr.proofview in
-    let proofview = Proofview.V82.instantiate_evar n com sp in
+    let tac =
+      Proofview.tclBIND Proofview.tclEVARMAP begin fun sigma ->
+      let (evk, evi) =
+        let evl = Evarutil.non_instantiated sigma in
+        let evl = Evar.Map.bindings evl in
+        if (n <= 0) then
+          CErrors.error "incorrect existential variable index"
+        else if CList.length evl < n then
+          CErrors.error "not so many uninstantiated existential variables"
+        else
+          CList.nth evl (n-1)
+      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 = Evar_refiner.w_refine (evk, evi) (ltac_vars, rawc) sigma in
+      Proofview.Unsafe.tclEVARS sigma
+    end in
+    let ((), proofview, _, _) = Proofview.apply (Global.env ()) tac pr.proofview in
     let shelf =
       List.filter begin fun g ->
         Evd.is_undefined (Proofview.return proofview) g
diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml
index f22cdbcc..e753e972 100644
--- a/proofs/proof_global.ml
+++ b/proofs/proof_global.ml
@@ -23,8 +23,9 @@ open Names
 (* Type of proof modes :
     - A function [set] to set it *from standard mode*
     - A function [reset] to reset the *standard mode* from it *)
+type proof_mode_name = string
 type proof_mode = {
-  name : string ;
+  name : proof_mode_name ;
   set : unit -> unit ;
   reset : unit -> unit
 }
@@ -33,10 +34,10 @@ let proof_modes = Hashtbl.create 6
 let find_proof_mode n =
   try Hashtbl.find proof_modes n
   with Not_found ->
-    Errors.error (Format.sprintf "No proof mode named \"%s\"." n)
+    CErrors.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)
+  Hashtbl.add proof_modes n (CEphemeron.create m)
 
 (* initial mode: standard mode *)
 let standard = { name = "No" ; set = (fun ()->()) ; reset = (fun () -> ()) }
@@ -45,6 +46,9 @@ let _ = register_proof_mode standard
 (* Default proof mode, to be set at the beginning of proofs. *)
 let default_proof_mode = ref (find_proof_mode "No")
 
+let get_default_proof_mode_name () =
+  (CEphemeron.default !default_proof_mode standard).name
+
 let _ =
   Goptions.declare_string_option {Goptions.
     optsync = true ;
@@ -52,7 +56,7 @@ let _ =
     optname = "default proof mode" ;
     optkey = ["Default";"Proof";"Mode"] ;
     optread = begin fun () ->
-      (Ephemeron.default !default_proof_mode standard).name
+      (CEphemeron.default !default_proof_mode standard).name
     end;
     optwrite = begin fun n ->
       default_proof_mode := find_proof_mode n
@@ -83,15 +87,18 @@ type closed_proof = proof_object * proof_terminator
 
 type pstate = {
   pid : Id.t;
-  terminator : proof_terminator Ephemeron.key;
+  terminator : proof_terminator CEphemeron.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;
+  mode : proof_mode CEphemeron.key;
   universe_binders: universe_binders option;
 }
 
+let make_terminator f = f
+let apply_terminator f = f
+
 (* 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 pstates = ref ([] : pstate list)
@@ -103,11 +110,11 @@ let current_proof_mode = ref !default_proof_mode
 let update_proof_mode () =
   match !pstates with
   | { mode = m } :: _ ->
-      Ephemeron.iter_opt !current_proof_mode (fun x -> x.reset ());
+      CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ());
       current_proof_mode := m;
-      Ephemeron.iter_opt !current_proof_mode (fun x -> x.set ())
+      CEphemeron.iter_opt !current_proof_mode (fun x -> x.set ())
   | _ ->
-      Ephemeron.iter_opt !current_proof_mode (fun x -> x.reset ());
+      CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ());
       current_proof_mode := find_proof_mode "No"
 
 (* combinators for the current_proof lists *)
@@ -115,15 +122,15 @@ let push a l = l := a::!l;
   update_proof_mode ()
 
 exception NoSuchProof
-let _ = Errors.register_handler begin function
-  | NoSuchProof -> Errors.error "No such proof."
-  | _ -> raise Errors.Unhandled
+let _ = CErrors.register_handler begin function
+  | NoSuchProof -> CErrors.error "No such proof."
+  | _ -> raise CErrors.Unhandled
 end
 
 exception NoCurrentProof
-let _ = Errors.register_handler begin function
-  | NoCurrentProof -> Errors.error "No focused proof (No proof-editing in progress)."
-  | _ -> raise Errors.Unhandled
+let _ = CErrors.register_handler begin function
+  | NoCurrentProof -> CErrors.error "No focused proof (No proof-editing in progress)."
+  | _ -> raise CErrors.Unhandled
 end
 
 (*** Proof Global manipulation ***)
@@ -183,7 +190,7 @@ let check_no_pending_proof () =
   if not (there_are_pending_proofs ()) then
     ()
   else begin
-    Errors.error (Pp.string_of_ppcmds
+    CErrors.error (Pp.string_of_ppcmds
       (str"Proof editing in progress" ++ msg_proofs () ++ fnl() ++
        str"Use \"Abort All\" first or complete proof(s)."))
   end
@@ -195,7 +202,7 @@ 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
+    CErrors.user_err_loc
       (loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs ())
 
 let discard_current () =
@@ -215,9 +222,9 @@ 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 ())
+  CEphemeron.iter_opt (find_proof_mode mode) (fun x -> x.set ())
+let disactivate_current_proof_mode () =
+  CEphemeron.iter_opt !current_proof_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
@@ -230,7 +237,7 @@ let disactivate_proof_mode mode =
 let start_proof sigma id ?pl str goals terminator =
   let initial_state = {
     pid = id;
-    terminator = Ephemeron.create terminator;
+    terminator = CEphemeron.create terminator;
     proof = Proof.start sigma goals;
     endline_tactic = None;
     section_vars = None;
@@ -242,7 +249,7 @@ let start_proof sigma id ?pl str goals terminator =
 let start_dependent_proof id ?pl str goals terminator =
   let initial_state = {
     pid = id;
-    terminator = Ephemeron.create terminator;
+    terminator = CEphemeron.create terminator;
     proof = Proof.dependent_start goals;
     endline_tactic = None;
     section_vars = None;
@@ -264,18 +271,19 @@ let _ = Goptions.declare_bool_option
       Goptions.optwrite = (fun b -> proof_using_auto_clear := b) }
 
 let set_used_variables l =
+  let open Context.Named.Declaration in
   let env = Global.env () in
   let ids = List.fold_right Id.Set.add l Id.Set.empty in
   let ctx = Environ.keep_hyps env ids in
   let ctx_set =
-    List.fold_right Id.Set.add (List.map pi1 ctx) Id.Set.empty in
+    List.fold_right Id.Set.add (List.map get_id ctx) Id.Set.empty in
   let vars_of = Environ.global_vars_set in
   let aux env entry (ctx, all_safe, to_clear as orig) =
     match entry with
-    | (x,None,_) ->
+    | LocalAssum (x,_) ->
        if Id.Set.mem x all_safe then orig
        else (ctx, all_safe, (Loc.ghost,x)::to_clear) 
-    | (x,Some bo, ty) as decl ->
+    | LocalDef (x,bo, ty) as decl ->
        if Id.Set.mem x all_safe then orig else
        let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in
        if Id.Set.subset vars all_safe
@@ -288,7 +296,7 @@ let set_used_variables l =
   | [] -> raise NoCurrentProof
   | p :: rest ->
       if not (Option.is_empty p.section_vars) then
-        Errors.error "Used section variables can be declared only once";
+        CErrors.error "Used section variables can be declared only once";
       pstates := { p with section_vars = Some ctx} :: rest;
       ctx, to_clear
 
@@ -299,6 +307,11 @@ let get_open_goals () =
     (List.map (fun (l1,l2) -> List.length l1 + List.length l2) gll) +
     List.length shelf
 
+let constrain_variables init uctx =
+  let levels = Univ.Instance.levels (Univ.UContext.instance init) in
+  let cstrs = UState.constrain_variables levels uctx in
+  Univ.ContextSet.add_constraints cstrs (UState.context_set uctx)
+
 let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl =
   let { pid; section_vars; strength; proof; terminator; universe_binders } =
     cur_pstate () in
@@ -329,7 +342,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl =
         if keep_body_ucst_separate ||
            not (Safe_typing.empty_private_constants = eff) then
           let initunivs = Evd.evar_context_universe_context initial_euctx in
-          let ctx = Evd.evar_universe_context_set initunivs universes in
+          let ctx = constrain_variables initunivs universes in
           (* For vi2vo compilation proofs are computed now but we need to
            * complement the univ constraints of the typ with the ones of
            * the body.  So we keep the two sets distinct. *)
@@ -338,7 +351,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl =
           (initunivs, typ), ((body, ctx_body), eff)
         else
           let initunivs = Univ.UContext.empty in
-          let ctx = Evd.evar_universe_context_set initunivs universes in
+          let ctx = constrain_variables initunivs universes in
           (* 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 *)
@@ -353,7 +366,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl =
         let initunivs = Evd.evar_context_universe_context initial_euctx in
         Future.from_val (initunivs, nf t),
         Future.chain ~pure:true p (fun (pt,eff) ->
-          (pt,Evd.evar_universe_context_set initunivs (Future.force univs)),eff)
+          (pt,constrain_variables initunivs (Future.force univs)),eff)
   in
   let entries =
     Future.map2 (fun p (_, t) ->
@@ -375,7 +388,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl =
   in
   { id = pid; entries = entries; persistence = strength;
     universes = (universes, binders) },
-  fun pr_ending -> Ephemeron.get terminator pr_ending
+  fun pr_ending -> CEphemeron.get terminator pr_ending
 
 type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context
 
@@ -395,7 +408,7 @@ let return_proof ?(allow_partial=false) () =
   let evd =
     let error s =
       let prf = str " (in proof " ++ Id.print pid ++ str ")" in
-      raise (Errors.UserError("last tactic before Qed",s ++ prf))
+      raise (CErrors.UserError("last tactic before Qed",s ++ prf))
     in
     try Proof.return proof with
     | Proof.UnfinishedProof ->
@@ -423,11 +436,11 @@ let close_proof ~keep_body_ucst_separate fix_exn =
 
 (** 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 get_terminator () = CEphemeron.get ( cur_pstate() ).terminator
 let set_terminator hook =
   match !pstates with
   | [] -> raise NoCurrentProof
-  | p :: ps -> pstates := { p with terminator = Ephemeron.create hook } :: ps
+  | p :: ps -> pstates := { p with terminator = CEphemeron.create hook } :: ps
 
 
 
@@ -458,7 +471,7 @@ module Bullet = struct
   type behavior = {
     name : string;
     put : Proof.proof -> t -> Proof.proof;
-    suggest: Proof.proof -> string option
+    suggest: Proof.proof -> std_ppcmds
   }
 
   let behaviors = Hashtbl.create 4
@@ -468,7 +481,7 @@ module Bullet = struct
   let none = {
     name = "None";
     put = (fun x _ -> x);
-    suggest = (fun _ -> None)
+    suggest = (fun _ -> mt ())
   }
   let _ = register_behavior none
 
@@ -484,36 +497,30 @@ module Bullet = struct
     (* 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.")
+      | NeedClosingBrace -> str"Try unfocusing with \"}\"."
+      | NoBulletInUse -> mt ()
+      | ProofFinished -> mt ()
+      | Suggest b -> str"Focus next goal with bullet " ++ pr_bullet b ++ str"."
+      | Unfinished b -> str"The current bullet " ++ pr_bullet b ++ str" is unfinished."
 
     (* give always a message. *)
     let suggest_on_error sugg =
       match sugg with
-      | NeedClosingBrace -> "Try unfocusing with \"}\"."
+      | NeedClosingBrace -> str"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.")
+      | ProofFinished -> str"No more subgoals."
+      | Suggest b -> str"Bullet " ++ pr_bullet b ++ str" is mandatory here."
+      | Unfinished b -> str"Current bullet " ++ pr_bullet b ++ str" is not finished."
 
     exception FailedBullet of t * suggestion
 
     let _ =
-      Errors.register_handler
+      CErrors.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)
+	  let prefix = str"Wrong bullet " ++ pr_bullet b ++ str" : " in
+	  CErrors.errorlabstrm "Focus" (prefix ++ suggest_on_error sugg)
+	| _ -> raise CErrors.Unhandled)
 
 
     (* spiwack: we need only one focus kind as we keep a stack of (distinct!) bullets *)
@@ -610,7 +617,7 @@ module Bullet = struct
     let _ = register_behavior strict
   end
 
-  (* Current bullet behavior, controled by the option *)
+  (* Current bullet behavior, controlled by the option *)
   let current_behavior = ref Strict.strict
 
   let _ =
@@ -626,7 +633,7 @@ module Bullet = struct
 	current_behavior :=
           try Hashtbl.find behaviors n
           with Not_found ->
-            Errors.error ("Unknown bullet behavior: \"" ^ n ^ "\".")
+            CErrors.error ("Unknown bullet behavior: \"" ^ n ^ "\".")
       end
     }
 
@@ -657,21 +664,26 @@ let _ =
 let default_goal_selector = ref (Vernacexpr.SelectNth 1)
 let get_default_goal_selector () = !default_goal_selector
 
+let print_range_selector (i, j) =
+  if i = j then string_of_int i
+  else string_of_int i ^ "-" ^ string_of_int j
+
 let print_goal_selector = function
   | Vernacexpr.SelectAll -> "all"
   | Vernacexpr.SelectNth i -> string_of_int i
+  | Vernacexpr.SelectList l -> "[" ^
+      String.concat ", " (List.map print_range_selector l) ^ "]"
   | 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
+      let err_msg = "The default 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;
+              if i < 0 then CErrors.error err_msg;
               Vernacexpr.SelectNth i
-        with Failure _ -> Errors.error err_msg
+        with Failure _ -> CErrors.error err_msg
       end
 
 let _ =
@@ -700,7 +712,7 @@ type state = pstate list
 let freeze ~marshallable =
   match marshallable with
   | `Yes ->
-      Errors.anomaly (Pp.str"full marshalling of proof state not supported")
+      CErrors.anomaly (Pp.str"full marshalling of proof state not supported")
   | `Shallow -> !pstates
   | `No -> !pstates
 let unfreeze s = pstates := s; update_proof_mode ()
diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli
index 7fbd183e..59daa296 100644
--- a/proofs/proof_global.mli
+++ b/proofs/proof_global.mli
@@ -16,8 +16,9 @@
     - A function [reset] to reset the *standard mode* from it 
 
 *)
+type proof_mode_name = string
 type proof_mode = {
-  name : string ;
+  name : proof_mode_name ;
   set : unit -> unit ;
   reset : unit -> unit
 }
@@ -27,6 +28,7 @@ type proof_mode = {
     One mode is already registered - the standard mode - named "No",
     It corresponds to Coq default setting are they are set when coqtop starts. *)
 val register_proof_mode : proof_mode -> unit
+val get_default_proof_mode_name : unit -> proof_mode_name
 
 val there_are_pending_proofs : unit -> bool
 val check_no_pending_proof : unit -> unit
@@ -40,7 +42,7 @@ val discard_all : unit -> unit
 
 (** [set_proof_mode] sets the proof mode to be used after it's called. It is
     typically called by the Proof Mode command. *)
-val set_proof_mode : string -> unit
+val set_proof_mode : proof_mode_name -> unit
 
 exception NoCurrentProof
 val give_me_the_proof : unit -> Proof.proof
@@ -70,9 +72,12 @@ type proof_ending =
   | Proved of Vernacexpr.opacity_flag *
              (Vernacexpr.lident * Decl_kinds.theorem_kind option) option *
               proof_object
-type proof_terminator = proof_ending -> unit
+type proof_terminator
 type closed_proof = proof_object * proof_terminator
 
+val make_terminator : (proof_ending -> unit) -> proof_terminator
+val apply_terminator : proof_terminator -> proof_ending -> unit
+
 (** [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
@@ -150,8 +155,8 @@ val get_universe_binders : unit -> universe_binders option
 (**********************************************************)
 
 
-val activate_proof_mode : string -> unit
-val disactivate_proof_mode : string -> unit
+val activate_proof_mode : proof_mode_name -> unit
+val disactivate_current_proof_mode : unit -> unit
 
 (**********************************************************)
 (*                                                        *)
@@ -169,7 +174,7 @@ module Bullet : sig
   type behavior = {
     name : string;
     put : Proof.proof -> t -> Proof.proof;
-    suggest: Proof.proof -> string option
+    suggest: Proof.proof -> Pp.std_ppcmds
   }
 
   (** A registered behavior can then be accessed in Coq
@@ -186,7 +191,7 @@ module Bullet : sig
   (** Handles focusing/defocusing with bullets:
        *)
   val put : Proof.proof -> t -> Proof.proof
-  val suggest : Proof.proof -> string option
+  val suggest : Proof.proof -> Pp.std_ppcmds
 end
 
 
diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml
deleted file mode 100644
index dd2c7b25..00000000
--- a/proofs/proof_type.ml
+++ /dev/null
@@ -1,52 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i*)
-open Evd
-open Names
-open Term
-open Tacexpr
-open Glob_term
-open Nametab
-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 =
-  | 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
-  | 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
-
-(** Ltac traces *)
-
-type ltac_call_kind =
-  | LtacMLCall of glob_tactic_expr
-  | LtacNotationCall of KerName.t
-  | LtacNameCall of ltac_constant
-  | LtacAtomCall of glob_atomic_tactic_expr
-  | LtacVarCall of Id.t * glob_tactic_expr
-  | LtacConstrInterp of glob_constr * Pretyping.ltac_var_map
-
-type ltac_trace = (Loc.t * ltac_call_kind) list
-
-let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make ()
diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli
index aa05f58a..c1207962 100644
--- a/proofs/proof_type.mli
+++ b/proofs/proof_type.mli
@@ -6,6 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(** Legacy proof engine. Do not use in newly written code. *)
+
 open Evd
 open Names
 open Term
@@ -19,57 +21,12 @@ open Misctypes
 
 type prim_rule =
   | 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
-  | 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]
-             evar_hyps = [the hypotheses of the subgoal]
-             evar_body = Evar_Empty;
-             evar_info = \{ pgm    : [The Realizer pgm if any]
-                           lc     : [Set of evar num occurring in subgoal] \}\}
-   sigma = \{ stamp = [an int chardacterizing the ed field, for quick compare]
-             ed : [A set of existential variables depending in the subgoal]
-               number of first evar,
-               it = \{ evar_concl = [the type of first evar]
-                      evar_hyps = [the context of the evar]
-                      evar_body = [the body of the Evar if any]
-                      evar_info = \{ pgm    : [Useless ??]
-                                    lc     : [Set of evars occurring
-                                              in the type of evar] \} \};
-               ...
-               number of last evar,
-               it = \{ evar_concl = [the type of evar]
-                      evar_hyps = [the context of the evar]
-                      evar_body = [the body of the Evar if any]
-                      evar_info = \{ pgm    : [Useless ??]
-                                    lc     : [Set of evars occurring
-                                              in the type of evar] \} \} \} v}
-*)
-
 type goal = Goal.goal
 
 type tactic = goal sigma -> goal list sigma
-
-(** Ltac traces *)
-
-(** TODO: Move those definitions somewhere sensible *)
-
-type ltac_call_kind =
-  | LtacMLCall of glob_tactic_expr
-  | LtacNotationCall of KerName.t
-  | LtacNameCall of ltac_constant
-  | LtacAtomCall of glob_atomic_tactic_expr
-  | LtacVarCall of Id.t * glob_tactic_expr
-  | LtacConstrInterp of glob_constr * Pretyping.ltac_var_map
-
-type ltac_trace = (Loc.t * ltac_call_kind) list
-
-val ltac_trace_info : ltac_trace Exninfo.t
diff --git a/proofs/proof_using.ml b/proofs/proof_using.ml
index a69645b1..caa9b328 100644
--- a/proofs/proof_using.ml
+++ b/proofs/proof_using.ml
@@ -10,6 +10,7 @@ open Names
 open Environ
 open Util
 open Vernacexpr
+open Context.Named.Declaration
 
 let to_string e =
   let rec aux = function
@@ -33,7 +34,8 @@ let in_nameset =
 
 let rec close_fwd e s =
   let s' =
-    List.fold_left (fun s (id,b,ty) ->      
+    List.fold_left (fun s decl ->
+      let (id,b,ty) = Context.Named.Declaration.to_tuple decl in
       let vb = Option.(default Id.Set.empty (map (global_vars_set e) b)) in
       let vty = global_vars_set e ty in
       let vbty = Id.Set.union vb vty in
@@ -61,13 +63,13 @@ and set_of_id env ty id =
         Id.Set.union (global_vars_set env ty) acc)
       Id.Set.empty ty
   else if Id.to_string id = "All" then
-    List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty
+    List.fold_right Id.Set.add (List.map get_id (named_context env)) Id.Set.empty
   else if CList.mem_assoc_f Id.equal id !known_names then
     process_expr env (CList.assoc_f Id.equal id !known_names) []
   else Id.Set.singleton id
 
 and full_set env =
-  List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty
+  List.fold_right Id.Set.add (List.map get_id (named_context env)) Id.Set.empty
 
 let process_expr env e ty =
   let ty_expr = SsSingl(Loc.ghost, Id.of_string "Type") in
@@ -126,7 +128,7 @@ let suggest_Proof_using name env vars ids_typ context_ids =
   if S.equal all_needed fwd_typ then valid (str "Type*");
   if S.equal all all_needed then valid(str "All");
   valid (pr_set false needed);
-  msg_info (
+  Feedback.msg_info (
     str"The proof of "++ str name ++ spc() ++
     str "should start with one of the following commands:"++spc()++
     v 0 (
diff --git a/proofs/proof_using.mli b/proofs/proof_using.mli
index 1bf38b69..b2c65412 100644
--- a/proofs/proof_using.mli
+++ b/proofs/proof_using.mli
@@ -6,6 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(** Utility code for section variables handling in Proof using... *)
+
 val process_expr :
   Environ.env -> Vernacexpr.section_subset_expr -> Constr.types list ->
     Names.Id.t list
diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib
index 32bf5576..804a5436 100644
--- a/proofs/proofs.mllib
+++ b/proofs/proofs.mllib
@@ -2,18 +2,13 @@ Miscprint
 Goal
 Evar_refiner
 Proof_using
-Proof_type
-Proof_errors
-Logic_monad
-Proofview_monad
 Logic
-Proofview
+Refine
 Proof
 Proof_global
 Redexpr
 Refiner
 Tacmach
 Pfedit
-Tactic_debug
 Clenv
 Clenvtac
diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml
index ea21917a..72cb05f1 100644
--- a/proofs/redexpr.ml
+++ b/proofs/redexpr.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Term
@@ -17,7 +17,7 @@ open Genredexpr
 open Pattern
 open Reductionops
 open Tacred
-open Closure
+open CClosure
 open RedFlags
 open Libobject
 open Misctypes
@@ -29,17 +29,22 @@ let cbv_vm env sigma c =
     error "vm_compute does not support existential variables.";
   Vnorm.cbv_vm env c ctyp
 
+let warn_native_compute_disabled =
+  CWarnings.create ~name:"native-compute-disabled" ~category:"native-compiler"
+  (fun () ->
+   strbrk "native_compute disabled at configure time; falling back to vm_compute.")
+
 let cbv_native env sigma c =
   if Coq_config.no_native_compiler then
-    let () = msg_warning (str "native_compute disabled at configure time; falling back to vm_compute.") in
-    cbv_vm env sigma c
+    (warn_native_compute_disabled ();
+     cbv_vm env sigma c)
   else
     let ctyp = Retyping.get_type_of env sigma c in
     Nativenorm.native_norm env sigma c ctyp
 
 let whd_cbn flags env sigma t =
   let (state,_) =
-    (whd_state_gen true flags env sigma (t,Reductionops.Stack.empty))
+    (whd_state_gen true true flags env sigma (t,Reductionops.Stack.empty))
   in Reductionops.Stack.zip ~refold:true state
 
 let strong_cbn flags =
@@ -141,7 +146,9 @@ let make_flag_constant = function
 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
+  let red = if f.rMatch then red_add red fMATCH else red in
+  let red = if f.rFix then red_add red fFIX else red in
+  let red = if f.rCofix then red_add red fCOFIX else red in
   let red = if f.rZeta then red_add red fZETA else red in
   let red =
     if f.rDelta then (* All but rConst *)
@@ -158,8 +165,6 @@ let make_flag env f =
 	  f.rConst red
   in red
 
-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 String.Map.empty
@@ -196,7 +201,7 @@ let out_arg = function
 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 e_red f = { e_redfun = fun env evm c -> Sigma.here (f env (Sigma.to_evar_map evm) c) evm }
 
 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.
@@ -211,6 +216,11 @@ let contextualize f g = function
       e_red (contextually b (l,c) (fun _ -> h))
   | None -> e_red g
 
+let warn_simpl_unfolding_modifiers =
+  CWarnings.create ~name:"simpl-unfolding-modifiers" ~category:"tactics"
+         (fun () ->
+          Pp.strbrk "The legacy simpl ignores constant unfolding modifiers.")
+
 let reduction_of_red_expr env =
   let make_flag = make_flag env in
   let rec reduction_of_red_expr = function
@@ -223,7 +233,7 @@ let reduction_of_red_expr env =
      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
+	 warn_simpl_unfolding_modifiers () 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 ->
diff --git a/proofs/redexpr.mli b/proofs/redexpr.mli
index b9191108..d4c2c4a6 100644
--- a/proofs/redexpr.mli
+++ b/proofs/redexpr.mli
@@ -6,6 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(** Interpretation layer of redexprs such as hnf, cbv, etc. *)
+
 open Names
 open Term
 open Pattern
diff --git a/proofs/refine.ml b/proofs/refine.ml
new file mode 100644
index 00000000..3f552706
--- /dev/null
+++ b/proofs/refine.ml
@@ -0,0 +1,162 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Util
+open Sigma.Notations
+open Proofview.Notations
+open Context.Named.Declaration
+
+let extract_prefix env info =
+  let ctx1 = List.rev (Environ.named_context env) in
+  let ctx2 = List.rev (Evd.evar_context info) in
+  let rec share l1 l2 accu = match l1, l2 with
+  | d1 :: l1, d2 :: l2 ->
+    if d1 == d2 then share l1 l2 (d1 :: accu)
+    else (accu, d2 :: l2)
+  | _ -> (accu, l2)
+  in
+  share ctx1 ctx2 []
+
+let typecheck_evar ev env sigma =
+  let info = Evd.find sigma ev in
+  (** Typecheck the hypotheses. *)
+  let type_hyp (sigma, env) decl =
+    let t = get_type decl in
+    let evdref = ref sigma in
+    let _ = Typing.e_sort_of env evdref t in
+    let () = match decl with
+    | LocalAssum _ -> ()
+    | LocalDef (_,body,_) -> Typing.e_check env evdref body t
+    in
+    (!evdref, Environ.push_named decl env)
+  in
+  let (common, changed) = extract_prefix env info in
+  let env = Environ.reset_with_named_context (Environ.val_of_named_context common) env in
+  let (sigma, env) = List.fold_left type_hyp (sigma, env) changed in
+  (** Typecheck the conclusion *)
+  let evdref = ref sigma in
+  let _ = Typing.e_sort_of env evdref (Evd.evar_concl info) in
+  !evdref
+
+let typecheck_proof c concl env sigma =
+  let evdref = ref sigma in
+  let () = Typing.e_check env evdref c concl in
+  !evdref
+
+let (pr_constrv,pr_constr) =
+  Hook.make ~default:(fun _env _sigma _c -> Pp.str"<constr>") ()
+
+(* Get the side-effect's constant declarations to update the monad's
+  * environmnent *)
+let add_if_undefined kn cb env =
+  try ignore(Environ.lookup_constant kn env); env
+  with Not_found -> Environ.add_constant kn cb env
+
+(* Add the side effects to the monad's environment, if not already done. *)
+let add_side_effect env = function
+  | { Entries.eff = Entries.SEsubproof (kn, cb, eff_env) } ->
+    add_if_undefined kn cb env
+  | { Entries.eff = Entries.SEscheme (l,_) } ->
+    List.fold_left (fun env (_,kn,cb,eff_env) ->
+        add_if_undefined kn cb env) env l
+
+let add_side_effects env effects =
+  List.fold_left (fun env eff -> add_side_effect env eff) env effects
+
+let make_refine_enter ?(unsafe = true) f =
+  { enter = fun gl ->
+  let gl = Proofview.Goal.assume gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let sigma = Sigma.to_evar_map sigma in
+  let env = Proofview.Goal.env gl in
+  let concl = Proofview.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 ((v,c), sigma) = Sigma.run (Evd.reset_future_goals sigma) f in
+  let evs = Evd.future_goals sigma in
+  let evkmain = Evd.principal_future_goal sigma in
+  (** Redo the effects in sigma in the monad's env *)
+  let privates_csts = Evd.eval_side_effects sigma in
+  let sideff = Safe_typing.side_effects_of_private_constants privates_csts in
+  let env = add_side_effects env sideff 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 self = Proofview.Goal.goal gl in
+  let _ =
+    if not (Evarutil.occur_evar_upto sigma self c) then ()
+    else Pretype_errors.error_occur_check env sigma self c
+  in
+  (** Proceed to the refinement *)
+  let sigma = match evkmain with
+    | None -> Evd.define self c sigma
+    | Some evk ->
+        let id = Evd.evar_ident self sigma in
+        let sigma = Evd.define self c sigma in
+        match id with
+        | None -> sigma
+        | Some id -> Evd.rename evk id 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 = CList.map_filter (Proofview.Unsafe.advance sigma) (CList.rev evs) in
+  let sigma = CList.fold_left Proofview.Unsafe.mark_as_goal sigma comb in
+  let trace () = Pp.(hov 2 (str"simple refine"++spc()++ Hook.get pr_constrv env sigma c)) in
+  Proofview.Trace.name_tactic trace (Proofview.tclUNIT v) >>= fun v ->
+  Proofview.Unsafe.tclSETENV (Environ.reset_context env) <*>
+  Proofview.Unsafe.tclEVARS sigma <*>
+  Proofview.Unsafe.tclSETGOALS comb <*>
+  Proofview.tclUNIT v
+  }
+
+let refine_one ?(unsafe = true) f =
+  Proofview.Goal.enter_one (make_refine_enter ~unsafe f)
+
+let refine ?(unsafe = true) f =
+  let f = { run = fun sigma -> let Sigma (c,sigma,p) = f.run sigma in Sigma (((),c),sigma,p) } in
+  Proofview.Goal.enter (make_refine_enter ~unsafe f)
+
+(** 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 = Proofview.Goal.enter { enter = begin fun gl ->
+  let gl = Proofview.Goal.assume gl in
+  let concl = Proofview.Goal.concl gl in
+  let env = Proofview.Goal.env gl in
+  let f = { run = fun h ->
+    let Sigma (c, h, p) = f.run h in
+    let sigma, c = with_type env (Sigma.to_evar_map h) c concl in
+    Sigma (c, Sigma.Unsafe.of_evar_map sigma, p)
+  } in
+  refine ?unsafe f
+end }
+
+(** {7 solve_constraints}
+
+  Ensure no remaining unification problems are left. Run at every "." by default. *)
+
+let solve_constraints =
+  let open Proofview in
+  tclENV >>= fun env -> tclEVARMAP >>= fun sigma ->
+   try let sigma = Evarconv.solve_unif_constraints_with_heuristics env sigma in
+       Unsafe.tclEVARSADVANCE sigma
+   with e -> tclZERO e
diff --git a/proofs/refine.mli b/proofs/refine.mli
new file mode 100644
index 00000000..a44632ef
--- /dev/null
+++ b/proofs/refine.mli
@@ -0,0 +1,50 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** The primitive refine tactic used to fill the holes in partial proofs. This
+    is the recommanded way to write tactics when the proof term is easy to
+    write down. Note that this is not the user-level refine tactic defined
+    in Ltac which is actually based on the one below. *)
+
+open Proofview
+
+(** {6 The refine tactic} *)
+
+(** 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 -> Constr.t Sigma.run -> 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. Exceptions
+    raised during the interpretation of [t] are caught and result in
+    tactic failures. If [unsafe] is [false] (default is [true]) [t] is
+    type-checked beforehand. *)
+
+val refine_one : ?unsafe:bool -> ('a * Constr.t) Sigma.run -> 'a tactic
+(** A generalization of [refine] which assumes exactly one goal under focus *)
+
+(** {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 -> Constr.t Sigma.run -> unit tactic
+(** Like {!refine} except the refined term is coerced to the conclusion of the
+    current goal. *)
+
+(** {7 Unification constraint handling} *)
+
+val solve_constraints : unit tactic
+(** Solve any remaining unification problems, applying heuristics. *)
diff --git a/proofs/refiner.ml b/proofs/refiner.ml
index 14493458..ea8543b0 100644
--- a/proofs/refiner.ml
+++ b/proofs/refiner.ml
@@ -7,13 +7,13 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Evd
 open Environ
 open Proof_type
 open Logic
-
+open Context.Named.Declaration
 
 let sig_it x = x.it
 let project x = x.sigma
@@ -57,7 +57,7 @@ let tclIDTAC gls = goal_goal_list gls
 
 (* the message printing identity tactic *)
 let tclIDTAC_MESSAGE s gls =
-  Pp.msg_info (hov 0 s); pp_flush (); tclIDTAC gls
+  Feedback.msg_info (hov 0 s); tclIDTAC gls
 
 (* General failure tactic *)
 let tclFAIL_s s gls = errorlabstrm "Refiner.tclFAIL_s" (str s)
@@ -197,12 +197,12 @@ let tclNOTSAMEGOAL (tac : tactic) goal =
    destruct), this is not detected by this tactical. *)
 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 oldhyps:Context.Named.t = 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 =
+  let hyps:Context.Named.t list =
     List.map (fun gl -> pf_hyps { it = gl; sigma=sigma; }) gls in
-  let cmp (i1, c1, t1) (i2, c2, t2) = Names.Id.equal i1 i2 in
+  let cmp d1 d2 = Names.Id.equal (get_id d1) (get_id d2) in
   let newhyps =
     List.map
       (fun hypl -> List.subtract cmp hypl oldhyps)
@@ -215,12 +215,13 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma)
     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)
+	   (fun acc d -> (Names.Id.to_string (get_id d)) ^ " " ^ acc)
 	   "" lh))
     "" newhyps in
-  pp (str (emacs_str "<infoH>")
+  Feedback.msg_notice
+    (str (emacs_str "<infoH>")
       ++  (hov 0 (str s))
-      ++  (str (emacs_str "</infoH>")) ++ fnl());
+      ++  (str (emacs_str "</infoH>")));
   tclIDTAC goal;;
 
 
@@ -239,8 +240,8 @@ let tclORELSE0 t1 t2 g =
   try
     t1 g
   with (* Breakpoint *)
-    | e when Errors.noncritical e ->
-      let e = Errors.push e in catch_failerror e; t2 g
+    | e when CErrors.noncritical e ->
+      let e = CErrors.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 *)
@@ -252,8 +253,8 @@ 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 ->
-      let e = Errors.push e in catch_failerror e; None
+    with e when CErrors.noncritical e ->
+      let e = CErrors.push e in catch_failerror e; None
   with
     | None -> t2else gls
     | Some sgl ->
@@ -283,12 +284,12 @@ let ite_gen tcal tac_if continue tac_else gl=
       try
         tac_else gl
       with
-        e' when Errors.noncritical e' -> iraise e in
+        e' when CErrors.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
+  | e when CErrors.noncritical e ->
+    let e = CErrors.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 *)
diff --git a/proofs/refiner.mli b/proofs/refiner.mli
index 13a9be59..6dcafb77 100644
--- a/proofs/refiner.mli
+++ b/proofs/refiner.mli
@@ -6,7 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Context
+(** Legacy proof engine. Do not use in newly written code. *)
+
 open Evd
 open Proof_type
 
@@ -16,7 +17,7 @@ val sig_it  : 'a sigma -> 'a
 val project : 'a sigma -> evar_map
 
 val pf_env  : goal sigma -> Environ.env
-val pf_hyps : goal sigma -> named_context
+val pf_hyps : goal sigma -> Context.Named.t
 
 val unpackage : 'a sigma -> evar_map ref * 'a
 val repackage : evar_map ref -> 'a -> 'a sigma
diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml
index a75b6fa0..330594af 100644
--- a/proofs/tacmach.ml
+++ b/proofs/tacmach.ml
@@ -18,6 +18,8 @@ open Tacred
 open Proof_type
 open Logic
 open Refiner
+open Sigma.Notations
+open Context.Named.Declaration
 
 let re_sig it  gc = { it = it; sigma = gc; }
 
@@ -40,21 +42,22 @@ let pf_hyps  = Refiner.pf_hyps
 let pf_concl gls = Goal.V82.concl (project gls) (sig_it gls)
 let pf_hyps_types gls  =
   let sign = Environ.named_context (pf_env gls) in
-  List.map (fun (id,_,x) -> (id, x)) sign
+  List.map (function LocalAssum (id,x)
+                   | LocalDef (id,_,x) -> id, x)
+           sign
 
-let pf_nth_hyp_id gls n = let (id,c,t) = List.nth (pf_hyps gls) (n-1) in id
+let pf_nth_hyp_id gls n = List.nth (pf_hyps gls) (n-1) |> get_id
 
 let pf_last_hyp gl = List.hd (pf_hyps gl)
 
 let pf_get_hyp gls id =
   try
-    Context.lookup_named id (pf_hyps gls)
+    Context.Named.lookup id (pf_hyps gls)
   with Not_found ->
     raise (RefinerError (NoSuchHyp id))
 
 let pf_get_hyp_typ gls id =
-  let (_,_,ty)= (pf_get_hyp gls id) in
-  ty
+  pf_get_hyp gls id |> get_type
 
 let pf_ids_of_hyps gls = ids_of_named_context (pf_hyps gls)
 
@@ -70,7 +73,10 @@ let pf_get_new_ids ids gls =
 let pf_global gls id = Constrintern.construct_reference (pf_hyps gls) id
 
 let pf_reduction_of_red_expr gls re c =
-  (fst (reduction_of_red_expr (pf_env gls) re)) (pf_env gls) (project gls) c
+  let (redfun, _) = reduction_of_red_expr (pf_env gls) re in
+  let sigma = Sigma.Unsafe.of_evar_map (project gls) in
+  let Sigma (c, sigma, _) = redfun.e_redfun (pf_env gls) sigma c in
+  (Sigma.to_evar_map sigma, c)
 
 let pf_apply f gls = f (pf_env gls) (project gls)
 let pf_eapply f gls x = 
@@ -78,7 +84,7 @@ let pf_eapply f gls x =
 let pf_reduce = pf_apply
 let pf_e_reduce = pf_apply
 
-let pf_whd_betadeltaiota         = pf_reduce whd_betadeltaiota
+let pf_whd_all         = pf_reduce whd_all
 let pf_hnf_constr                = pf_reduce hnf_constr
 let pf_nf                        = pf_reduce simpl
 let pf_nf_betaiota               = pf_reduce (fun _ -> nf_betaiota)
@@ -95,7 +101,7 @@ 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_hnf_type_of gls          = pf_whd_all gls % pf_get_type_of gls
 
 let pf_is_matching              = pf_apply Constr_matching.is_matching_conv
 let pf_matches                  = pf_apply Constr_matching.matches_conv
@@ -115,26 +121,11 @@ let internal_cut_rev_no_check replace id t gl =
 let refine_no_check c gl =
   refiner (Refine c) gl
 
-(* This does not check dependencies *)
-let thin_no_check ids gl =
-  if List.is_empty ids then tclIDTAC gl else refiner (Thin ids) 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 (FixRule (f,n,others,j))) gl
-
-let mutual_cofix f others j gl =
-  with_check (refiner (Cofix (f,others,j))) gl
-
 (* Versions with consistency checks *)
 
 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 thin c             = with_check (thin_no_check c)
-let move_hyp id id'  = with_check (move_hyp_no_check id id')
 
 (* Pretty-printers *)
 
@@ -158,11 +149,15 @@ let pr_glls glls =
 (* Variants of [Tacmach] functions built with the new proof engine *)
 module New = struct
 
+  let project gl =
+    let sigma = Proofview.Goal.sigma gl in
+    Sigma.to_evar_map sigma
+
   let pf_apply f gl =
-    f (Proofview.Goal.env gl) (Proofview.Goal.sigma gl)
+    f (Proofview.Goal.env gl) (project gl)
 
   let of_old f gl =
-    f { Evd.it = Proofview.Goal.goal gl ; sigma = Proofview.Goal.sigma gl }
+    f { Evd.it = Proofview.Goal.goal gl ; sigma = project gl; }
 
   let pf_global id gl =
     (** We only check for the existence of an [id] in [hyps] *)
@@ -176,6 +171,9 @@ module New = struct
   let pf_unsafe_type_of gl t =
     pf_apply unsafe_type_of gl t
 
+  let pf_get_type_of gl t =
+    pf_apply (Retyping.get_type_of ~lax:true) gl t
+
   let pf_type_of gl t =
     pf_apply type_of gl t
 
@@ -192,34 +190,35 @@ module New = struct
     next_ident_away id ids
 
   let pf_get_hyp id gl =
-    let hyps = Proofview.Goal.hyps gl in
+    let hyps = Proofview.Goal.env gl in
     let sign =
-      try Context.lookup_named id hyps
+      try Environ.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
+    pf_get_hyp id gl |> get_type
 
   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
+    List.map (function LocalAssum (id,x)
+                     | LocalDef (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) =
+  let pf_nf_concl (gl : ([ `LZ ], 'r) 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
+    let sigma = project gl in
     nf_evar sigma concl
 
-  let pf_whd_betadeltaiota gl t = pf_apply whd_betadeltaiota gl t
+  let pf_whd_all gl t = pf_apply whd_all gl t
 
   let pf_get_type_of gl t = pf_apply Retyping.get_type_of gl t
 
@@ -228,13 +227,13 @@ module New = struct
 
   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)
+    pf_whd_all 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_whd_all gl t = pf_apply whd_all 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
+  let pf_nf_evar gl t = nf_evar (project gl) t
 
 end
diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli
index 7e943cb1..59f296f6 100644
--- a/proofs/tacmach.mli
+++ b/proofs/tacmach.mli
@@ -8,7 +8,6 @@
 
 open Names
 open Term
-open Context
 open Environ
 open Evd
 open Proof_type
@@ -34,18 +33,18 @@ val apply_sig_tac :
 
 val pf_concl              : goal sigma -> types
 val pf_env                : goal sigma -> env
-val pf_hyps               : goal sigma -> named_context
+val pf_hyps               : goal sigma -> Context.Named.t
 (*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_last_hyp           : goal sigma -> Context.Named.Declaration.t
 val pf_ids_of_hyps        : goal sigma -> Id.t list
 val pf_global             : goal sigma -> Id.t -> constr
 val pf_unsafe_type_of            : goal sigma -> constr -> types
 val pf_type_of            : goal sigma -> constr -> evar_map * types
 val pf_hnf_type_of        : goal sigma -> constr -> types
 
-val pf_get_hyp            : goal sigma -> Id.t -> named_declaration
+val pf_get_hyp            : goal sigma -> Id.t -> Context.Named.Declaration.t
 val pf_get_hyp_typ        : goal sigma -> Id.t -> types
 
 val pf_get_new_id  : Id.t      -> goal sigma -> Id.t
@@ -64,7 +63,7 @@ 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_all       : goal sigma -> constr -> constr
 val pf_hnf_constr              : goal sigma -> constr -> constr
 val pf_nf                      : goal sigma -> constr -> constr
 val pf_nf_betaiota             : goal sigma -> constr -> constr
@@ -87,18 +86,12 @@ val pf_is_matching : goal sigma -> constr_pattern -> constr -> bool
 val refiner                   : rule -> tactic
 val internal_cut_no_check     : bool -> Id.t -> types -> tactic
 val refine_no_check           : constr -> tactic
-val thin_no_check             : Id.t list -> tactic
-val mutual_fix      :
-  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 internal_cut     : bool -> Id.t -> types -> tactic
 val internal_cut_rev : bool -> Id.t -> types -> tactic
 val refine           : constr -> tactic
-val thin             : Id.t list -> tactic
-val move_hyp         : Id.t -> Id.t move_location -> tactic
 
 (** {6 Pretty-printing functions (debug only). } *)
 val pr_gls    : goal sigma -> Pp.std_ppcmds
@@ -106,36 +99,47 @@ val pr_glls   : goal list sigma -> Pp.std_ppcmds
 
 (* 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
+  val pf_apply : (env -> evar_map -> 'a) -> ('b, 'r) Proofview.Goal.t -> 'a
+  val pf_global : identifier -> ('a, 'r) Proofview.Goal.t -> constr
+  (** FIXME: encapsulate the level in an existential type. *)
+  val of_old : (Proof_type.goal Evd.sigma -> 'a) -> ([ `NF ], 'r) Proofview.Goal.t -> 'a
 
-  val pf_env : 'a Proofview.Goal.t -> Environ.env
-  val pf_concl : [ `NF ] Proofview.Goal.t -> types
+  val project : ('a, 'r) Proofview.Goal.t -> Evd.evar_map
+  val pf_env : ('a, 'r) Proofview.Goal.t -> Environ.env
+  val pf_concl : ([ `NF ], 'r) Proofview.Goal.t -> types
 
-  val pf_unsafe_type_of : 'a Proofview.Goal.t -> Term.constr -> Term.types
-  val pf_type_of : 'a Proofview.Goal.t -> Term.constr -> evar_map * Term.types
-  val pf_conv_x : 'a Proofview.Goal.t -> Term.constr -> Term.constr -> bool
+  (** WRONG: To be avoided at all costs, it typechecks the term entirely but
+     forgets the universe constraints necessary to retypecheck it *)
+  val pf_unsafe_type_of : ('a, 'r) Proofview.Goal.t -> Term.constr -> Term.types
 
-  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
+  (** This function does no type inference and expects an already well-typed term.
+      It recomputes its type in the fastest way possible (no conversion is ever involved) *)
+  val pf_get_type_of : ('a, 'r) Proofview.Goal.t -> Term.constr -> Term.types
 
-  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
+  (** This function entirely type-checks the term and computes its type
+      and the implied universe constraints. *)
+  val pf_type_of : ('a, 'r) Proofview.Goal.t -> Term.constr -> evar_map * Term.types
+  val pf_conv_x : ('a, 'r) Proofview.Goal.t -> Term.constr -> Term.constr -> bool
 
-  val pf_nf_concl : [ `LZ ] Proofview.Goal.t -> types
-  val pf_reduce_to_quantified_ind : 'a Proofview.Goal.t -> types -> pinductive * types
+  val pf_get_new_id  : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> identifier
+  val pf_ids_of_hyps : ('a, 'r) Proofview.Goal.t -> identifier list
+  val pf_hyps_types : ('a, 'r) Proofview.Goal.t -> (identifier * types) list
 
-  val pf_hnf_constr : 'a Proofview.Goal.t -> constr -> types
-  val pf_hnf_type_of : 'a Proofview.Goal.t -> constr -> types
+  val pf_get_hyp : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> Context.Named.Declaration.t
+  val pf_get_hyp_typ        : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> types
+  val pf_last_hyp           : ([ `NF ], 'r) Proofview.Goal.t -> Context.Named.Declaration.t
 
-  val pf_whd_betadeltaiota : 'a Proofview.Goal.t -> constr -> constr
-  val pf_compute : 'a Proofview.Goal.t -> constr -> constr
+  val pf_nf_concl : ([ `LZ ], 'r) Proofview.Goal.t -> types
+  val pf_reduce_to_quantified_ind : ('a, 'r) Proofview.Goal.t -> types -> pinductive * types
 
-  val pf_matches : 'a Proofview.Goal.t -> constr_pattern -> constr -> patvar_map
+  val pf_hnf_constr : ('a, 'r) Proofview.Goal.t -> constr -> types
+  val pf_hnf_type_of : ('a, 'r) Proofview.Goal.t -> constr -> types
 
-  val pf_nf_evar : 'a Proofview.Goal.t -> constr -> constr
+  val pf_whd_all : ('a, 'r) Proofview.Goal.t -> constr -> constr
+  val pf_compute : ('a, 'r) Proofview.Goal.t -> constr -> constr
+
+  val pf_matches : ('a, 'r) Proofview.Goal.t -> constr_pattern -> constr -> patvar_map
+
+  val pf_nf_evar : ('a, 'r) Proofview.Goal.t -> constr -> constr
 
 end
diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml
index cc973260..fa6422cd 100644
--- a/stm/asyncTaskQueue.ml
+++ b/stm/asyncTaskQueue.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Pp
 open Util
 
@@ -60,9 +60,7 @@ module Make(T : Task) = struct
 
   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
@@ -106,7 +104,8 @@ module Make(T : Task) = struct
       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))
+    let open Feedback in
+    feedback ~id:(State Stateid.initial) (WorkerStatus(id, s))
 
   module Worker = Spawn.Sync(struct end)
 
@@ -125,7 +124,7 @@ module Make(T : Task) = struct
                  "-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"
+        | ("-async-proofs" |"-toploop" |"-vio2vo"
           |"-load-vernac-source" |"-l" |"-load-vernac-source-verbose" |"-lv"
           |"-compile" |"-compile-verbose"
           |"-async-proofs-worker-priority" |"-worker-id") :: _ :: tl ->
@@ -184,6 +183,13 @@ module Make(T : Task) = struct
         let () = Unix.sleep 1 in
         kill_if ()
     in
+    let kill_if () =
+      try kill_if ()
+      with Sys.Break ->
+        let () = stop_waiting := true in
+        let () = TQueue.broadcast queue in
+        Worker.kill proc
+    in
     let _ = Thread.create kill_if () in
 
     try while true do
@@ -223,10 +229,8 @@ module Make(T : Task) = struct
     | (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 ()
+        giveback_exec_token (); kill proc; exit ()
   end
 
   module Pool = WorkerPool.Make(Model)
@@ -294,11 +298,27 @@ module Make(T : Task) = struct
   let slave_handshake () =
     Pool.worker_handshake (Option.get !slave_ic) (Option.get !slave_oc)
 
+  let pp_pid pp = 
+    (* Breaking all abstraction barriers... very nice *)
+    let get_xml pp = match Richpp.repr pp with
+      | Xml_datatype.Element("_", [], xml) -> xml
+      | _ -> assert false in
+    Richpp.richpp_of_xml (Xml_datatype.Element("_", [],
+      get_xml (Richpp.richpp_of_pp Pp.(str (System.process_id ()^ " "))) @
+      get_xml pp))
+
+  let debug_with_pid = Feedback.(function
+    | { contents = Message(Debug, loc, pp) } as fb ->
+       { fb with contents = Message(Debug,loc,pp_pid pp) }
+    | x -> x)
+
   let main_loop () =
+    (* We pass feedback to master *)
     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 ();
+      Marshal.to_channel oc (RespFeedback (debug_with_pid fb)) []; flush oc in
+    Feedback.add_feeder (fun x -> slave_feeder (Option.get !slave_oc) x);
+    Feedback.set_logger Feedback.feedback_logger;
+    (* We ask master to allocate universe identifiers *)
     Universes.set_remote_new_univ_level (bufferize (fun () ->
       marshal_response (Option.get !slave_oc) RespGetCounterNewUnivLevel;
       match unmarshal_more_data (Option.get !slave_ic) with
@@ -314,7 +334,7 @@ module Make(T : Task) = struct
         let response = slave_respond request in
         report_status "Idle";
         marshal_response (Option.get !slave_oc) response;
-        Ephemeron.clear ()
+        CEphemeron.clear ()
       with
       | MarshalError s ->
         pr_err ("Fatal marshal error: " ^ s); flush_all (); exit 2
@@ -337,7 +357,7 @@ module Make(T : Task) = struct
   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
+    with e -> let e = CErrors.push e in destroy q; iraise e
 
   let n_workers { active } = Pool.n_workers active
 
diff --git a/stm/dag.ml b/stm/dag.ml
index 0c7f9f34..99e7c926 100644
--- a/stm/dag.ml
+++ b/stm/dag.ml
@@ -8,15 +8,6 @@
 
 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
 
@@ -31,45 +22,57 @@ module type S = sig
   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
 
+  module Property :
+  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
+    val having_it : 'd t -> NodeSet.t
+  end
+
+  val create_property : ('e,'i,'d) t -> node list -> 'd -> ('e,'i,'d) t
+  val property_of : ('e,'i,'d) t -> node -> 'd Property.t list
+  val del_property : ('e,'i,'d) t -> 'd Property.t -> ('e,'i,'d) t
+
+  val iter : ('e,'i,'d) t ->
+    (node -> 'd Property.t list -> 'i option ->
+      (node * 'e) list -> unit) -> unit
+
 end
 
 module Make(OT : Map.OrderedType) = struct
 
-module Cluster =
+module NodeSet = Set.Make(OT)
+
+module Property =
 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
+  type 'd t = { data : 'd; uid : int; having_it : NodeSet.t }
+  let equal { uid = i1 } { uid = i2 } = Int.equal i1 i2
+  let compare { uid = i1 } { uid = i2 } = Int.compare i1 i2
+  let to_string { uid = i } = string_of_int i
+  let data { data = d } = d
+  let having_it { having_it } = having_it
 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;
+  properties : 'data Property.t list NodeMap.t;
   infos : 'info NodeMap.t;
 }
 
 let empty = {
   graph = NodeMap.empty;
-  clusters = NodeMap.empty;
+  properties = NodeMap.empty;
   infos = NodeMap.empty;
 }
 
@@ -94,7 +97,7 @@ let del_edge dag id tgt = { dag with
 
 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;
+  properties = NodeMap.filter (fun n _ -> not(NodeSet.mem n s)) dag.properties;
   graph = NodeMap.filter (fun n l ->
       let drop = NodeSet.mem n s in
       if not drop then
@@ -102,20 +105,31 @@ let del_nodes dag s = {
       not drop)
     dag.graph }
 
+let map_add_list k v m =
+  try
+    let l = NodeMap.find k m in
+    NodeMap.add k (v::l) m
+  with Not_found -> NodeMap.add k [v] m
+
 let clid = ref 1
-let create_cluster dag l data =
+let create_property 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 having_it = List.fold_right NodeSet.add l NodeSet.empty in
+  let property = { Property.data; uid = !clid; having_it } in
+  { dag with properties =
+     List.fold_right (fun x ps -> map_add_list x property ps) l dag.properties }
+
+let property_of dag id =
+  try NodeMap.find id dag.properties
+  with Not_found -> []
+
+let del_property dag c =
+  { dag with properties =
+     NodeMap.filter (fun _ cl -> cl <> [])
+       (NodeMap.map (fun cl ->
+          List.filter (fun c' ->
+            not (Property.equal c' c)) cl)
+          dag.properties) }
 
 let get_info dag id =
   try Some (NodeMap.find id dag.infos)
@@ -126,7 +140,7 @@ 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
+  NodeMap.iter (fun k v -> f k (property_of dag k) (get_info dag k) v) dag.graph
 
 let all_nodes dag = NodeMap.domain dag.graph
 
diff --git a/stm/dag.mli b/stm/dag.mli
index 6b4442df..e783cd8e 100644
--- a/stm/dag.mli
+++ b/stm/dag.mli
@@ -7,19 +7,7 @@
 (************************************************************************)
 
 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
 
@@ -34,19 +22,35 @@ module type S = sig
   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
+  (* A property applies to a set of nodes and holds some data.
+     Stm uses this feature to group nodes contributing to the same proofs and
+     to structure proofs in boxes limiting the scope of errors *)
+  module Property :
+  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
+    val having_it : 'd t -> NodeSet.t
+  end
+
+  val create_property : ('e,'i,'d) t -> node list -> 'd -> ('e,'i,'d) t
+  val property_of : ('e,'i,'d) t -> node -> 'd Property.t list
+  val del_property : ('e,'i,'d) t -> 'd Property.t -> ('e,'i,'d) t
+
+  val iter : ('e,'i,'d) t -> 
+    (node -> 'd Property.t list -> 'i option ->
+      (node * 'e) list -> unit) -> unit
+
+  end
 
-module Make(OT : Map.OrderedType) : S with type node = OT.t
+module Make(OT : Map.OrderedType) : S
+with type node = OT.t
+and type NodeSet.t = Set.Make(OT).t
+and type NodeSet.elt = OT.t
 
diff --git a/stm/lemmas.ml b/stm/lemmas.ml
index f06abfcc..022c89ad 100644
--- a/stm/lemmas.ml
+++ b/stm/lemmas.ml
@@ -9,7 +9,7 @@
 (* Created by Hugo Herbelin from contents related to lemma proofs in
    file command.ml, Aug 2009 *)
 
-open Errors
+open CErrors
 open Util
 open Flags
 open Pp
@@ -31,20 +31,22 @@ open Reductionops
 open Constrexpr
 open Constrintern
 open Impargs
+open Context.Rel.Declaration
 
 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
+  with e when CErrors.noncritical e ->
+    let e = CErrors.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)
+      let open Context.Named.Declaration in
+      (get_value (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)
@@ -77,7 +79,7 @@ let adjust_guardness_conditions const = function
                     List.fold_left (fun e (_,c,cb,_) -> add c cb e) env l)
                 env (Safe_typing.side_effects_of_private_constants eff) in
               let indexes =
-	        search_guard Loc.ghost env
+                search_guard Loc.ghost env
                   possible_indexes fixdecls in
 		(mkFix ((indexes,0),fixdecls), ctx), eff
           | _ -> (body, ctx), eff) }
@@ -104,20 +106,21 @@ let find_mutually_recursive_statements thms =
       (* 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))
+        (fun env c -> fst (whd_all_stack env Evd.empty c))
         (Global.env()) hyps in
       let ind_hyps =
-        List.flatten (List.map_i (fun i (_,b,t) ->
+        List.flatten (List.map_i (fun i decl ->
+          let t = get_type decl 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.CoFinite && Option.is_empty b ->
+                mind.mind_finite <> Decl_kinds.CoFinite && is_local_assum decl ->
               [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
+        let whnf_ccl,_ = whd_all_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
@@ -147,7 +150,7 @@ let find_mutually_recursive_statements thms =
 	  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.");
+	    if_verbose Feedback.msg_info (str "Assuming mutual coinductive statements.");
 	  flush_all ();
           indccl, true, []
       | [], _::_ ->
@@ -155,7 +158,7 @@ let find_mutually_recursive_statements thms =
           | ind :: _ ->
             if List.distinct_f ind_ord (List.map pi1 ind)
             then
-              if_verbose msg_info
+              if_verbose Feedback.msg_info
                 (strbrk
                    ("Coinductive statements do not follow the order of "^
                     "definition, assuming the proof to be by induction."));
@@ -207,8 +210,8 @@ let save ?export_seff id const cstrs pl do_guard (locality,poly,kind) hook =
     definition_message id;
     Option.iter (Universes.register_universe_binders r) pl;
     call_hook (fun exn -> exn) hook l r
-  with e when Errors.noncritical e ->
-    let e = Errors.push e in
+  with e when CErrors.noncritical e ->
+    let e = CErrors.push e in
     iraise (fix_exn e)
 
 let default_thm_id = Id.of_string "Unnamed_thm"
@@ -249,10 +252,14 @@ let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i,
   | 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
+      let rec body_i t = match kind_of_term t with
         | Fix ((nv,0),decls) -> mkFix ((nv,i),decls)
         | CoFix (0,decls) -> mkCoFix (i,decls)
+        | LetIn(na,t1,ty,t2) -> mkLetIn (na,t1,ty, body_i t2)
+        | Lambda(na,ty,t) -> mkLambda(na,ty,body_i t)
+        | App (t, args) -> mkApp (body_i t, args)
         | _ -> anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr body) in
+      let body_i = body_i body in
       match locality with
       | Discharge ->
           let const = definition_entry ~types:t_i ~opaque:opaq ~poly:p 
@@ -298,13 +305,16 @@ let save_anonymous_with_strength ?export_seff proof kind save_ident =
 
 (* Admitted *)
 
+let warn_let_as_axiom =
+  CWarnings.create ~name:"let-as-axiom" ~category:"vernacular"
+                   (fun id -> strbrk "Let definition" ++ spc () ++ pr_id id ++
+                                spc () ++ strbrk "declared as an axiom.")
+
 let admit (id,k,e) pl hook () =
   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.")
+  | Local, _, _ | Discharge, _, _ -> warn_let_as_axiom id
   in
   let () = assumption_message id in
   Option.iter (Universes.register_universe_binders (ConstRef kn)) pl;
@@ -329,10 +339,11 @@ let check_exist =
   )
 
 let universe_proof_terminator compute_guard hook =
-  let open Proof_global in function
+  let open Proof_global in
+  make_terminator begin function
   | Admitted (id,k,pe,(ctx,pl)) ->
       admit (id,k,pe) pl (hook (Some ctx)) ();
-      Pp.feedback Feedback.AddedAxiom
+      Feedback.feedback Feedback.AddedAxiom
   | Proved (opaque,idopt,proof) ->
       let is_opaque, export_seff, exports = match opaque with
         | Vernacexpr.Transparent -> false, true, []
@@ -347,12 +358,16 @@ let universe_proof_terminator compute_guard hook =
           save_anonymous_with_strength ~export_seff proof kind id
       end;
       check_exist exports
+  end
 
 let standard_proof_terminator compute_guard hook =
   universe_proof_terminator compute_guard (fun _ -> hook)
 
-let start_proof id ?pl kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook =
-  let terminator = standard_proof_terminator compute_guard hook in
+let start_proof id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook =
+  let terminator = match terminator with
+  | None -> standard_proof_terminator compute_guard hook
+  | Some terminator -> terminator compute_guard hook
+  in
   let sign = 
     match sign with
     | Some sign -> sign
@@ -361,8 +376,11 @@ let start_proof id ?pl kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook =
   !start_hook c;
   Pfedit.start_proof id ?pl kind sigma sign c ?init_tac terminator
 
-let start_proof_univs id ?pl kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook =
-  let terminator = universe_proof_terminator compute_guard hook in
+let start_proof_univs id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook =
+  let terminator = match terminator with
+  | None -> universe_proof_terminator compute_guard hook
+  | Some terminator -> terminator compute_guard hook
+  in
   let sign = 
     match sign with
     | Some sign -> sign
@@ -392,7 +410,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook =
     | 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
+      let rec_tac = rec_tac_initializer finite guard thms snl in
       Some (match init_tac with
         | None -> 
             if Flags.is_auto_intros () then 
@@ -422,7 +440,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook =
             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 (*FIXME*) Univ.UContext.empty ctx in
+	    let ctx = UState.context_set (*FIXME*) 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
@@ -431,7 +449,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook =
 	  call_hook (fun exn -> exn) hook strength ref) thms_data in
       start_proof_univs id ?pl kind ctx t ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard
 
-let start_proof_com kind thms hook =
+let start_proof_com ?inference_hook kind thms hook =
   let env0 = Global.env () in
   let levels = Option.map snd (fst (List.hd thms)) in 
   let evdref = ref (match levels with
@@ -441,8 +459,10 @@ let start_proof_com kind thms hook =
   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
-    evdref := solve_remaining_evars all_and_fail_flags env !evdref (Evd.empty,!evdref);
-    let ids = List.map pi1 ctx in
+    let flags = all_and_fail_flags in
+    let flags = { flags with use_hook = inference_hook } in
+    evdref := solve_remaining_evars flags env !evdref (Evd.empty,!evdref);
+    let ids = List.map get_name 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'),
@@ -451,6 +471,11 @@ let start_proof_com kind thms hook =
   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
+  let () =
+    match levels with
+    | None -> ()
+    | Some l -> ignore (Evd.universe_context evd ?names:l)
+  in
   let evd =
     if pi2 kind then evd
     else (* We fix the variables to ensure they won't be lowered to Set *)
@@ -461,6 +486,18 @@ let start_proof_com kind thms hook =
 
 (* Saving a proof *)
 
+let keep_admitted_vars = ref true
+
+let _ =
+  let open Goptions in
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "keep section variables in admitted proofs";
+      optkey   = ["Keep"; "Admitted"; "Variables"];
+      optread  = (fun () -> !keep_admitted_vars);
+      optwrite = (fun b -> keep_admitted_vars := b) }
+
 let save_proof ?proof = function
   | Vernacexpr.Admitted ->
       let pe =
@@ -474,14 +511,18 @@ let save_proof ?proof = function
               error "Admitted requires an explicit statement";
             let typ = Option.get const_entry_type in
             let ctx = Evd.evar_context_universe_context (fst universes) in
-            Admitted(id, k, (const_entry_secctx, pi2 k, (typ, ctx), None), universes)
+            let sec_vars = if !keep_admitted_vars then const_entry_secctx else None in
+            Admitted(id, k, (sec_vars, pi2 k, (typ, ctx), None), universes)
         | None ->
+            let pftree = Pfedit.get_pftreestate () in
             let id, k, typ = Pfedit.current_proof_statement () in
+            let universes = Proof.initial_euctx pftree in
             (* This will warn if the proof is complete *)
-            let pproofs, universes =
+            let pproofs, _univs =
               Proof_global.return_proof ~allow_partial:true () in
             let sec_vars =
-              match  Pfedit.get_used_variables(), pproofs with
+              if not !keep_admitted_vars then None
+              else match  Pfedit.get_used_variables(), pproofs with
               | Some _ as x, _ -> x
               | None, (pproof, _) :: _ -> 
                   let env = Global.env () in
@@ -490,11 +531,12 @@ let save_proof ?proof = function
                   Some (Environ.keep_hyps env (Idset.union ids_typ ids_def))
               | _ -> None in
 	    let names = Pfedit.get_universe_binders () in
-            let binders, ctx = Evd.universe_context ?names (Evd.from_ctx universes) in
+            let evd = Evd.from_ctx universes in
+            let binders, ctx = Evd.universe_context ?names evd in
             Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None),
 		     (universes, Some binders))
       in
-      Proof_global.get_terminator() pe
+      Proof_global.apply_terminator (Proof_global.get_terminator ()) pe
   | Vernacexpr.Proved (is_opaque,idopt) ->
       let (proof_obj,terminator) =
         match proof with
@@ -504,12 +546,10 @@ let save_proof ?proof = function
       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))
+      Proof_global.(apply_terminator terminator (Proved (is_opaque,idopt,proof_obj)))
 
 (* Miscellaneous *)
 
 let get_current_context () =
-  try Pfedit.get_current_goal_context ()
-  with e when Logic.catchable_exception e ->
-    let env = Global.env () in
-    (Evd.from_env env, env)
+  Pfedit.get_current_context ()
+           
diff --git a/stm/lemmas.mli b/stm/lemmas.mli
index 16e54e31..39c089be 100644
--- a/stm/lemmas.mli
+++ b/stm/lemmas.mli
@@ -9,8 +9,6 @@
 open Names
 open Term
 open Decl_kinds
-open Constrexpr
-open Vernacexpr
 open Pfedit
 
 type 'a declaration_hook
@@ -24,16 +22,20 @@ val call_hook :
 val set_start_hook : (types -> unit) -> unit
 
 val start_proof : Id.t -> ?pl:universe_binders -> goal_kind -> Evd.evar_map ->
+  ?terminator:(lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator) ->
   ?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 -> ?pl:universe_binders -> goal_kind -> Evd.evar_map ->
+  ?terminator:(lemma_possible_guards -> (Evd.evar_universe_context option -> unit declaration_hook) -> Proof_global.proof_terminator) ->
   ?sign:Environ.named_context_val -> types ->
   ?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards -> 
   (Evd.evar_universe_context option -> unit declaration_hook) -> unit
 
-val start_proof_com : goal_kind -> Vernacexpr.proof_expr list ->
+val start_proof_com :
+  ?inference_hook:Pretyping.inference_hook ->
+  goal_kind -> Vernacexpr.proof_expr list ->
   unit declaration_hook -> unit
 
 val start_proof_with_initialization : 
@@ -43,6 +45,11 @@ val start_proof_with_initialization :
      (types * (Name.t list * Impargs.manual_explicitation list))) list
   -> int list option -> unit declaration_hook -> unit
 
+val universe_proof_terminator :
+  Proof_global.lemma_possible_guards ->
+    (Evd.evar_universe_context option -> unit declaration_hook) ->
+    Proof_global.proof_terminator
+
 val standard_proof_terminator :
   Proof_global.lemma_possible_guards -> unit declaration_hook ->
     Proof_global.proof_terminator
@@ -60,4 +67,3 @@ val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> uni
    and the current global env *)
 
 val get_current_context : unit -> Evd.evar_map * Environ.env
-
diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml
new file mode 100644
index 00000000..8162fc3b
--- /dev/null
+++ b/stm/proofBlockDelimiter.ml
@@ -0,0 +1,184 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Stm
+
+module Util : sig
+
+val simple_goal : Evd.evar_map -> Goal.goal -> Goal.goal list -> bool
+val is_focused_goal_simple : Stateid.t -> [ `Simple of Goal.goal list | `Not ]
+
+type 'a until = [ `Stop | `Found of static_block_declaration | `Cont of 'a ]
+
+val crawl :
+  document_view -> ?init:document_node option ->
+  ('a -> document_node -> 'a until) -> 'a ->
+    static_block_declaration option
+
+val unit_val : Stm.DynBlockData.t
+val of_bullet_val : Vernacexpr.bullet -> Stm.DynBlockData.t
+val to_bullet_val : Stm.DynBlockData.t -> Vernacexpr.bullet
+val of_vernac_expr_val : Vernacexpr.vernac_expr -> Stm.DynBlockData.t
+val to_vernac_expr_val : Stm.DynBlockData.t -> Vernacexpr.vernac_expr
+
+end = struct
+
+let unit_tag = DynBlockData.create "unit"
+let unit_val = DynBlockData.Easy.inj () unit_tag
+
+let of_bullet_val, to_bullet_val = DynBlockData.Easy.make_dyn "bullet"
+let of_vernac_expr_val, to_vernac_expr_val = DynBlockData.Easy.make_dyn "vernac_expr"
+
+let simple_goal sigma g gs =
+  let open Evar in
+  let open Evd in
+  let open Evarutil in
+  let evi = Evd.find sigma g in
+  Set.is_empty (evars_of_term evi.evar_concl) &&
+  Set.is_empty (evars_of_filtered_evar_info (nf_evar_info sigma evi)) &&
+  not (List.exists (Proofview.depends_on sigma g) gs)
+
+let is_focused_goal_simple id =
+  match state_of_id id with
+  | `Expired | `Error _ | `Valid None -> `Not
+  | `Valid (Some { proof }) ->
+       let proof = Proof_global.proof_of_state proof in
+       let focused, r1, r2, r3, sigma = Proof.proof proof in
+       let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in
+       if List.for_all (fun x -> simple_goal sigma x rest) focused
+       then `Simple focused
+       else `Not
+
+type 'a until = [ `Stop | `Found of static_block_declaration | `Cont of 'a ]
+
+let crawl { entry_point; prev_node } ?(init=Some entry_point) f acc =
+  let rec crawl node acc =
+    match node with
+    | None -> None
+    | Some node ->
+        match f acc node with
+        | `Stop -> None
+        | `Found x -> Some x
+        | `Cont acc -> crawl (prev_node node) acc in
+  crawl init acc
+
+end
+
+include Util
+
+(* ****************** - foo - bar - baz *********************************** *)
+
+let static_bullet ({ entry_point; prev_node } as view) =
+  match entry_point.ast with
+  | Vernacexpr.VernacBullet b ->
+      let base = entry_point.indentation in
+      let last_tac = prev_node entry_point in
+      crawl view ~init:last_tac (fun prev node ->
+        if node.indentation < base then `Stop else
+        if node.indentation > base then `Cont node else
+        match node.ast with
+        | Vernacexpr.VernacBullet b' when b = b' ->
+          `Found { block_stop = entry_point.id; block_start = prev.id;
+                   dynamic_switch = node.id; carry_on_data = of_bullet_val b }
+        | _ -> `Stop) entry_point
+  | _ -> assert false
+
+let dynamic_bullet { dynamic_switch = id; carry_on_data = b } =
+  match is_focused_goal_simple id with
+  | `Simple focused ->
+      `ValidBlock {
+         base_state = id;
+         goals_to_admit = focused;
+         recovery_command = Some (Vernacexpr.VernacBullet (to_bullet_val b))
+      }
+  | `Not -> `Leaks
+
+let () = register_proof_block_delimiter
+  "bullet" static_bullet dynamic_bullet
+
+(* ******************** { block } ***************************************** *)
+  
+let static_curly_brace ({ entry_point; prev_node } as view) =
+  assert(entry_point.ast = Vernacexpr.VernacEndSubproof);
+  crawl view (fun (nesting,prev) node ->
+    match node.ast with
+    | Vernacexpr.VernacSubproof _ when nesting = 0 ->
+      `Found { block_stop = entry_point.id; block_start = prev.id;
+               dynamic_switch = node.id; carry_on_data = unit_val }
+    | Vernacexpr.VernacSubproof _ ->
+      `Cont (nesting - 1,node)
+    | Vernacexpr.VernacEndSubproof ->
+      `Cont (nesting + 1,node)
+    | _ -> `Cont (nesting,node)) (-1, entry_point)
+
+let dynamic_curly_brace { dynamic_switch = id } =
+  match is_focused_goal_simple id with
+  | `Simple focused ->
+      `ValidBlock {
+         base_state = id;
+         goals_to_admit = focused;
+         recovery_command = Some Vernacexpr.VernacEndSubproof
+      }
+  | `Not -> `Leaks
+
+let () = register_proof_block_delimiter
+  "curly" static_curly_brace dynamic_curly_brace
+
+(* ***************** par: ************************************************* *)
+
+let static_par { entry_point; prev_node } =
+  match prev_node entry_point with
+  | None -> None
+  | Some { id = pid } ->
+      Some { block_stop = entry_point.id; block_start = pid;
+             dynamic_switch = pid; carry_on_data = unit_val }
+
+let dynamic_par { dynamic_switch = id } =
+  match is_focused_goal_simple id with
+  | `Simple focused ->
+      `ValidBlock {
+         base_state = id;
+         goals_to_admit = focused;
+         recovery_command = None;
+      }
+  | `Not -> `Leaks
+
+let () = register_proof_block_delimiter "par" static_par dynamic_par
+
+(* ***************** simple indentation *********************************** *)
+
+let static_indent ({ entry_point; prev_node } as view) =
+   Printf.eprintf "@%d\n" (Stateid.to_int entry_point.id);
+   match prev_node entry_point with
+   | None -> None
+   | Some last_tac ->
+      if last_tac.indentation <= entry_point.indentation then None
+      else
+        crawl view ~init:(Some last_tac) (fun prev node ->
+        if node.indentation >= last_tac.indentation then `Cont node
+        else 
+          `Found { block_stop = entry_point.id; block_start = node.id;
+                   dynamic_switch = node.id;
+                   carry_on_data = of_vernac_expr_val entry_point.ast }
+        ) last_tac
+
+let dynamic_indent { dynamic_switch = id; carry_on_data = e } =
+  Printf.eprintf "%s\n" (Stateid.to_string id);
+  match is_focused_goal_simple id with
+  | `Simple [] -> `Leaks
+  | `Simple focused ->
+      let but_last = List.tl (List.rev focused) in 
+      `ValidBlock {
+         base_state = id;
+         goals_to_admit = but_last;
+         recovery_command = Some (to_vernac_expr_val e);
+      }
+  | `Not -> `Leaks
+
+let () = register_proof_block_delimiter "indent" static_indent dynamic_indent
+
diff --git a/stm/proofBlockDelimiter.mli b/stm/proofBlockDelimiter.mli
new file mode 100644
index 00000000..a55032a4
--- /dev/null
+++ b/stm/proofBlockDelimiter.mli
@@ -0,0 +1,41 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* This file implements proof block detection for:
+   - blocks delimited by { and }
+   - bullets with indentation
+   - par: terminator
+
+   It exports utility functions to ease the development of other proof block
+   detection code.
+*)
+
+(** A goal is simple if it nor depends on nor impacts on any other goal.
+    This function is used to detect, dynamically, if a proof block leaks,
+    i.e. if skipping it could impact other goals (like not instantiating their
+    type).  `Simple carries the list of focused goals.
+*)
+val simple_goal : Evd.evar_map -> Goal.goal -> Goal.goal list -> bool
+val is_focused_goal_simple : Stateid.t -> [ `Simple of Goal.goal list | `Not ]
+
+type 'a until = [ `Stop | `Found of Stm.static_block_declaration | `Cont of 'a ]
+
+(* Simpler function to crawl the document backward to detect the block.
+ * ?init is the entry point of the document view if not given *)
+val crawl :
+  Stm.document_view -> ?init:Stm.document_node option ->
+  ('a -> Stm.document_node -> 'a until) -> 'a ->
+    Stm.static_block_declaration option
+
+(* Dummy value for static_block_declaration when no real value is needed *)
+val unit_val : Stm.DynBlockData.t
+
+(* Bullets *)
+val of_bullet_val : Vernacexpr.bullet -> Stm.DynBlockData.t
+val to_bullet_val : Stm.DynBlockData.t -> Vernacexpr.bullet
+
diff --git a/stm/spawned.ml b/stm/spawned.ml
index c6df8726..c5bd5f6f 100644
--- a/stm/spawned.ml
+++ b/stm/spawned.ml
@@ -13,19 +13,6 @@ let prerr_endline s = if !Flags.debug then begin pr_err s end else ()
 
 type chandescr = AnonPipe | Socket of string * int * 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 pr pw =
   let open Unix in
   let _, cout = open_connection (ADDR_INET (inet_addr_of_string h,pr)) in
@@ -59,7 +46,7 @@ let control_channel = ref None
 let channels = ref None
 
 let init_channels () =
-  if !channels <> None then Errors.anomaly(Pp.str "init_channels called twice");
+  if !channels <> None then CErrors.anomaly(Pp.str "init_channels called twice");
   let () = match !main_channel with
   | None -> ()
   | Some (Socket(mh,mpr,mpw)) ->
@@ -78,7 +65,7 @@ let init_channels () =
   | Some (Socket (ch, cpr, cpw)) ->
     controller ch cpr cpw
   | Some AnonPipe ->
-    Errors.anomaly (Pp.str "control channel cannot be a pipe")
+    CErrors.anomaly (Pp.str "control channel cannot be a pipe")
 
 let get_channels () =
   match !channels with
diff --git a/stm/stm.ml b/stm/stm.ml
index d8b2de4a..b4331dc4 100644
--- a/stm/stm.ml
+++ b/stm/stm.ml
@@ -8,16 +8,21 @@
 
 let pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr
 
-let prerr_endline s = if false then begin pr_err s end else ()
-let prerr_debug s = if !Flags.debug then begin pr_err s end else ()
+let prerr_endline s = if false then begin pr_err (s ()) end else ()
+let prerr_debug s = if !Flags.debug then begin pr_err (s ()) end else ()
+
+(* Opening ppvernac below aliases Richpp, see PR#185 *)
+let pp_to_richpp  = Richpp.richpp_of_pp
+let str_to_richpp = Richpp.richpp_of_string
 
 open Vernacexpr
-open Errors
+open CErrors
 open Pp
 open Names
 open Util
 open Ppvernac
 open Vernac_classifier
+open Feedback
 
 module Hooks = struct
 
@@ -27,28 +32,25 @@ 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) ()
+    feedback ~id:(State state_id) 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 forward_feedback, forward_feedback_hook = 
+  let m = Mutex.create () in
+  Hook.make ~default:(function
+    | { id = id; route; contents } ->
+        try Mutex.lock m; feedback ~id:id ~route contents; Mutex.unlock m
+        with e -> Mutex.unlock m; raise e) ()
 
 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))) ()
+ ~default:(fun id loc msg ->
+        feedback ~id (Message(Error, Some loc, pp_to_richpp 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))) ()
+    feedback ~id:(State state_id) (Message(Error, Some loc, pp_to_richpp msg))) ()
 
 let unreachable_state, unreachable_state_hook = Hook.make
  ~default:(fun _ _ -> ()) ()
@@ -80,8 +82,28 @@ let interactive () =
 
 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
+type aast = {
+  verbose : bool;
+  loc : Loc.t;
+  indentation : int;
+  strlen : int;
+  mutable expr : vernac_expr; (* mutable: Proof using hinted by aux file *)
+}
+let pr_ast { expr; indentation } = int indentation ++ str " " ++ pr_vernac expr
+
+let default_proof_mode () = Proof_global.get_default_proof_mode_name ()
+
+(* Commands piercing opaque *)
+let may_pierce_opaque = function
+  | { expr = VernacPrint _ } -> true
+  | { expr = VernacExtend (("Extraction",_), _) } -> true
+  | { expr = VernacExtend (("SeparateExtraction",_), _) } -> true
+  | { expr = VernacExtend (("ExtractionLibrary",_), _) } -> true
+  | { expr = VernacExtend (("RecursiveExtractionLibrary",_), _) } -> true
+  | { expr = VernacExtend (("ExtractionConstant",_), _) } -> true
+  | { expr = VernacExtend (("ExtractionInlinedConstant",_), _) } -> true
+  | { expr = VernacExtend (("ExtractionInductive",_), _) } -> true
+  | _ -> false
 
 (* Wrapper for Vernacentries.interp to set the feedback id *)
 let vernac_interp ?proof id ?route { verbose; loc; expr } =
@@ -89,34 +111,48 @@ let vernac_interp ?proof id ?route { verbose; loc; expr } =
     | VernacResetName _ | VernacResetInitial | VernacBack _
     | VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _
     | VernacBacktrack _ | VernacAbortAll | VernacAbort _ -> true
-    | VernacTime el | VernacRedirect (_,el) -> List.for_all (fun (_,e) -> internal_command e) el
+    | VernacTime (_,e) | VernacTimeout (_,e) | VernacRedirect (_,(_,e)) -> internal_command e
     | _ -> false in
   if internal_command expr then begin
-    prerr_endline ("ignoring " ^ string_of_ppcmds(pr_vernac expr))
+    prerr_endline (fun () -> "ignoring " ^ Pp.string_of_ppcmds(pr_vernac expr))
   end else begin
-    set_id_for_feedback ?route (Feedback.State id);
+    set_id_for_feedback ?route (State id);
     Aux_file.record_in_aux_set_at loc;
-    prerr_endline ("interpreting " ^ string_of_ppcmds(pr_vernac expr));
+    prerr_endline (fun () -> "interpreting " ^ Pp.string_of_ppcmds(pr_vernac expr));
     try Hooks.(call interp ?verbosely:(Some verbose) ?proof (loc, expr))
     with e ->
-      let e = Errors.push e in
+      let e = CErrors.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 indentation_of_string s =
+  let len = String.length s in
+  let rec aux n i precise =
+    if i >= len then 0, precise, len
+    else
+      match s.[i] with
+      | ' ' | '\t' -> aux (succ n) (succ i) precise
+      | '\n' | '\r' -> aux 0 (succ i) true
+      | _ -> n, precise, len in
+  aux 0 0 false
+
+let vernac_parse ?(indlen_prev=fun() -> 0) ?newtip ?route eid s =
   let feedback_id = 
-    if Option.is_empty newtip then Feedback.Edit eid
-    else Feedback.State (Option.get newtip) in
+    if Option.is_empty newtip then Edit eid
+    else State (Option.get newtip) in
+  let indentation, precise, strlen = indentation_of_string s in
+  let indentation =
+    if precise then indentation else indlen_prev () + indentation 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
+      | Some (loc, ast) -> indentation, strlen, loc, ast
+    with e when CErrors.noncritical e ->
+      let (e, info) = CErrors.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))
@@ -124,13 +160,13 @@ let vernac_parse ?newtip ?route eid s =
 
 let pr_open_cur_subgoals () =
   try Printer.pr_open_subgoals ()
-  with Proof_global.NoCurrentProof -> str""
+  with Proof_global.NoCurrentProof -> Pp.str ""
 
 let update_global_env () =
   if Proof_global.there_are_pending_proofs () then
     Proof_global.update_global_env ()
 
-module Vcs_ = Vcs.Make(Stateid)
+module Vcs_ = Vcs.Make(Stateid.Self)
 type future_proof = Proof_global.closed_proof_output Future.computation
 type proof_mode = string
 type depth = int
@@ -140,22 +176,27 @@ type branch_type =
   | `Proof of proof_mode * depth
   | `Edit of
       proof_mode * Stateid.t * Stateid.t  * vernac_qed_type * Vcs_.Branch.t ]
+(* TODO 8.7 : split commands and tactics, since this type is too messy now *)
 type cmd_t = {
-  ctac : bool; (* is a tactic, needed by the 8.4 semantics of Undo *)
-  ceff : bool; (* is a side-effecting command *)
-  cast : ast;
+  ctac : bool; (* is a tactic *)
+  ceff : bool; (* is a side-effecting command in the middle of a proof *)
+  cast : aast;
   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
+  cblock : proof_block_name option;
+  cqueue : [ `MainQueue
+           | `TacQueue of solving_tac * anon_abstracting_tac * cancel_switch
+           | `QueryQueue of cancel_switch
+           | `SkipQueue ] }
+type fork_t = aast * Vcs_.Branch.t * Vernacexpr.opacity_guarantee * Id.t list
 type qed_t = {
-  qast : ast;
+  qast : aast;
   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 * ast
+type seff_t = aast option
+type alias_t = Stateid.t * aast
 type transaction =
   | Cmd    of cmd_t
   | Fork   of fork_t
@@ -167,40 +208,69 @@ 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 ]
+  | `Sideff of [ `Ast of aast * Stateid.t | `Id of Stateid.t ]
   | `Alias  of alias_t ]
 type visit = { step : step; next : Stateid.t }
 
+let mkTransTac cast cblock cqueue =
+  Cmd { ctac = true; cast; cblock; cqueue; cids = []; ceff = false }
+let mkTransCmd cast cids ceff cqueue =
+  Cmd { ctac = false; cast; cblock = None; cqueue; cids; ceff }
 
 (* Parts of the system state that are morally part of the proof state *)
 let summary_pstate = [ Evarutil.meta_counter_summary_name;
-                       Evarutil.evar_counter_summary_name;
+                       Evd.evar_counter_summary_name;
                        "program-tcc-table" ]
-type state = {
-  system : States.state;
-  proof : Proof_global.state;
-  shallow : bool
+type cached_state =
+  | Empty
+  | Error of Exninfo.iexn
+  | Valid of state
+and state = { (* TODO: inline records in OCaml 4.03 *)
+  system : States.state;       (* summary + libstack *)
+  proof : Proof_global.state;  (* proof state *)
+  shallow : bool               (* is the state trimmed down (libstack) *)
 }
 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;
+type 'vcs state_info = { (* TODO: Make this record private to VCS *)
+  mutable n_reached : int;      (* debug cache: how many times was computed *)
+  mutable n_goals : int;        (* open goals: indentation *)
+  mutable state : cached_state; (* state value *)
   mutable vcs_backup : 'vcs option * backup option;
 }
 let default_info () =
-  { n_reached = 0; n_goals = 0; state = None; vcs_backup = None,None }
+  { n_reached = 0; n_goals = 0; state = Empty; vcs_backup = None,None }
+
+module DynBlockData : Dyn.S = Dyn.Make(struct end)
+
+(* Clusters of nodes implemented as Dag properties.  While Dag and Vcs impose
+ * no constraint on properties, here we impose boxes to be non overlapping.
+ * Such invariant makes sense for the current kinds of boxes (proof blocks and
+ * entire proofs) but may make no sense and dropped/refined in the future.
+ * Such invariant is useful to detect broken proof block detection code *)
+type box =
+  | ProofTask of pt
+  | ProofBlock of static_block_declaration * proof_block_name
+and pt = { (* TODO: inline records in OCaml 4.03 *)
+  lemma : Stateid.t;
+  qed   : Stateid.t;
+}
+and static_block_declaration = {
+  block_start : Stateid.t;
+  block_stop  : Stateid.t;
+  dynamic_switch : Stateid.t;
+  carry_on_data : DynBlockData.t;
+}
 
 (* 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 proof_nesting : (branch_type, 't,'i,'c) Vcs_.t -> int
   val find_proof_at_depth :
-    (branch_type, 't, 'i) Vcs_.t -> int ->
+          (branch_type, 't, 'i,'c) 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
+  val visit : (branch_type, transaction,'i,'c) Vcs_.t -> Vcs_.Dag.node -> visit
 
 end = struct (* {{{ *)
 
@@ -216,7 +286,7 @@ end = struct (* {{{ *)
   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")
+          | _, { Vcs_.kind = `Edit _ } -> anomaly(Pp.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"
@@ -224,9 +294,9 @@ end = struct (* {{{ *)
   exception Expired
   let visit vcs id =
     if Stateid.equal id Stateid.initial then
-      anomaly(str"Visiting the initial state id")
+      anomaly(Pp.str "Visiting the initial state id")
     else if Stateid.equal id Stateid.dummy then
-      anomaly(str"Visiting the dummy state id")
+      anomaly(Pp.str "Visiting the dummy state id")
     else
     try
       match Vcs_.Dag.from_node (Vcs_.dag vcs) id with
@@ -242,7 +312,7 @@ end = struct (* {{{ *)
       | [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))
+      | _ -> anomaly (Pp.str ("Malformed VCS at node "^Stateid.to_string id))
     with Not_found -> raise Expired
 
 end (* }}} *)
@@ -264,7 +334,7 @@ module VCS : sig
     pos  : id;
   }
 
-  type vcs = (branch_type, transaction, vcs state_info) Vcs_.t
+  type vcs = (branch_type, transaction, vcs state_info, box) Vcs_.t
 
   val init : id -> unit
 
@@ -278,30 +348,32 @@ module VCS : sig
   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 mk_branch_name : aast -> 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 reachable : id -> Stateid.Set.t
   val cur_tip : unit -> id
 
   val get_info : id -> vcs state_info
-  val reached : id -> bool -> unit
+  val reached : id -> unit
   val goals : id -> int -> unit
-  val set_state : id -> state -> unit
-  val get_state : id -> state option
+  val set_state : id -> cached_state -> unit
+  val get_state : id -> cached_state
 
   (* 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 slice : block_start:id -> block_stop:id -> vcs
+  val nodes_in_slice : block_start:id -> block_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 create_proof_task_box : id list -> qed:id -> block_start:id -> unit
+  val create_proof_block : static_block_declaration -> string -> unit
+  val box_of : id -> box list
+  val delete_boxes_of : id -> unit
+  val proof_task_box_of : id -> pt option
 
   val proof_nesting : unit -> int
   val checkout_shallowest_proof_branch : unit -> unit
-  val propagate_sideff : ast option -> unit
+  val propagate_sideff : replay:aast option -> unit
 
   val gc : unit -> unit
 
@@ -317,7 +389,6 @@ end = struct (* {{{ *)
   include Vcs_
   exception Expired = Vcs_aux.Expired
 
-  module StateidSet = Set.Make(Stateid)
   open Printf
 
   let print_dag vcs () =
@@ -325,21 +396,21 @@ end = struct (* {{{ *)
       "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")
+          (try Pp.string_of_ppcmds (pr_ast t) with _ -> "ERR")
       | Sideff (Some t) ->
           sprintf "Sideff(%s)"
-            (try string_of_ppcmds (pr_ast t) with _ -> "ERR")
+            (try Pp.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
+      | Some { state = Valid _ } -> true
       | _ -> false in
     let is_red id =
       match get_info vcs id with
-      | Some s -> Int.equal s.n_reached ~-1
+      | Some { state = Error _ } -> true
       | _ -> false in
     let head = current_branch vcs in
     let heads =
@@ -359,8 +430,6 @@ end = struct (* {{{ *)
     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 -> ""
@@ -373,39 +442,71 @@ end = struct (* {{{ *)
     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 ids = ref Stateid.Set.empty in
+    let boxes = ref [] in
+    (* Fill in *)
+    Dag.iter graph (fun from _ _ l ->
+      ids := Stateid.Set.add from !ids;
+      List.iter (fun box -> boxes := box :: !boxes)
+        (Dag.property_of graph from);
+      List.iter (fun (dest, _) ->
+        ids := Stateid.Set.add dest !ids;
+        List.iter (fun box -> boxes := box :: !boxes)
+          (Dag.property_of graph dest))
+      l);
+    boxes := CList.sort_uniquize Dag.Property.compare !boxes;
+
     let oc = open_out fname_dot in
     output_string oc "digraph states {\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
+       fprintf oc "%s -> %s [xlabel=%s,labelfloat=true];\n"
+           (node from) (node dest) (edge trans)) 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;
+
+    let contains b1 b2 =
+      Stateid.Set.subset
+        (Dag.Property.having_it b2) (Dag.Property.having_it b1) in
+    let same_box = Dag.Property.equal in
+    let outerboxes boxes =
+       List.filter (fun b ->
+         not (List.exists (fun b1 ->
+           not (same_box b1 b) && contains b1 b) boxes)           
+         ) boxes in
+    let rec rec_print b =
+      boxes := CList.remove same_box b !boxes;
+      let sub_boxes = List.filter (contains b) (outerboxes !boxes) in
+      fprintf oc "subgraph cluster_%s {\n" (Dag.Property.to_string b);
+      List.iter rec_print sub_boxes;
+      Stateid.Set.iter (fun id ->
+        if Stateid.Set.mem id !ids then begin
+          ids := Stateid.Set.remove id !ids;
+          nodefmt oc id
+        end)
+        (Dag.Property.having_it b);
+      match Dag.Property.data b with
+      | ProofBlock ({ dynamic_switch = id }, lbl) ->
+          fprintf oc "label=\"%s (test:%s)\";\n" lbl (Stateid.to_string id);
+          fprintf oc "color=red; }\n"
+      | ProofTask _ -> fprintf oc "color=blue; }\n"
+      in
+    List.iter rec_print (outerboxes !boxes);
+    Stateid.Set.iter (nodefmt oc) !ids;
+
     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
+  type vcs = (branch_type, transaction, vcs state_info, box) t
   let vcs : vcs ref = ref (empty Stateid.dummy)
 
   let init id =
@@ -442,13 +543,12 @@ end = struct (* {{{ *)
     | Some x -> x
     | None -> raise Vcs_aux.Expired
   let set_state id s =
-    (get_info id).state <- Some s;
+    (get_info id).state <- 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 reached id =
     let info = get_info id in
-    if b then info.n_reached <- info.n_reached + 1
-    else info.n_reached <- -1
+    info.n_reached <- info.n_reached + 1
   let goals id n = (get_info id).n_goals <- n
   let cur_tip () = get_branch_pos (current_branch ())
 
@@ -466,14 +566,14 @@ end = struct (* {{{ *)
         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);
+        prerr_endline (fun () -> "mode:" ^ mode);
         Proof_global.activate_proof_mode mode
       with Failure _ ->
         checkout Branch.master;
-        Proof_global.disactivate_proof_mode "Classic"
+        Proof_global.disactivate_current_proof_mode ()
 
   (* copies the transaction on every open branch *)
-  let propagate_sideff t =
+  let propagate_sideff ~replay:t =
     List.iter (fun b ->
       checkout b;
       let id = new_node () in
@@ -482,54 +582,91 @@ end = struct (* {{{ *)
   
   let visit id = Vcs_aux.visit !vcs id
 
-  let nodes_in_slice ~start ~stop =
+  let nodes_in_slice ~block_start ~block_stop =
     let rec aux id =
-      if Stateid.equal id start then [] else
+      if Stateid.equal id block_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
+      | _ -> anomaly(str("Cannot slice from "^ Stateid.to_string block_start ^
+                         " to "^Stateid.to_string block_stop))
+    in aux block_stop
 
-  let slice ~start ~stop =
-    let l = nodes_in_slice ~start ~stop in
+  let slice ~block_start ~block_stop =
+    let l = nodes_in_slice ~block_start ~block_stop in
     let copy_info v id =
       Vcs_.set_info v id
-        { (get_info id) with state = None; vcs_backup = None,None } in
+        { (get_info id) with state = Empty; 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 copy_proof_blockes v =
+      let nodes = Vcs_.Dag.all_nodes (Vcs_.dag v) in
+      let props =
+        Stateid.Set.fold (fun n pl -> Vcs_.property_of !vcs n @ pl) nodes [] in
+      let props = CList.sort_uniquize Vcs_.Dag.Property.compare props in
+      List.fold_left (fun v p ->
+        Vcs_.create_property v
+          (Stateid.Set.elements (Vcs_.Dag.Property.having_it p))
+          (Vcs_.Dag.Property.data p)) v props
+    in
+    let v = Vcs_.empty block_start in
+    let v = copy_info v block_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));
+    assert (match (get_info block_start).state with Valid _ -> true | _ -> false);
     (* 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)
+      match (get_info id).state with
+      | Empty | Error _ -> fill (Vcs_aux.visit v id).next
+      | Valid _ -> copy_info_w_state v id in
+    let v = fill block_stop in
+    (* We put in the new dag the first state (since Qed shall run on it,
+     * see check_task_aux) *)
+    let v = copy_info_w_state v block_start in
+    copy_proof_blockes v
+
+  let nodes_in_slice ~block_start ~block_stop =
+    List.rev (List.map fst (nodes_in_slice ~block_start ~block_stop))
+
+  let topo_invariant l =
+    let all = List.fold_right Stateid.Set.add l Stateid.Set.empty in
+    List.for_all
+      (fun x ->
+         let props = property_of !vcs x in
+         let sets = List.map Dag.Property.having_it props in
+         List.for_all (fun s -> Stateid.Set.(subset s all || subset all s)) sets)
+      l
+
+  let create_proof_task_box l ~qed ~block_start:lemma =
+    if not (topo_invariant l) then anomaly (str "overlapping boxes");
+    vcs := create_property !vcs l (ProofTask { qed; lemma })
+  let create_proof_block ({ block_start; block_stop} as decl) name =
+    let l = nodes_in_slice ~block_start ~block_stop in
+    if not (topo_invariant l) then anomaly (str "overlapping boxes");
+    vcs := create_property !vcs l (ProofBlock (decl, name))
+  let box_of id = List.map Dag.Property.data (property_of !vcs id)
+  let delete_boxes_of id =
+    List.iter (fun x -> vcs := delete_property !vcs x) (property_of !vcs id)
+  let proof_task_box_of id =
+    match
+      CList.map_filter (function ProofTask x -> Some x | _ -> None) (box_of id)
+    with
+    | [] -> None
+    | [x] -> Some x
+    | _ -> anomaly (str "node with more than 1 proof task box")
 
   let gc () =
     let old_vcs = !vcs in
     let new_vcs, erased_nodes = gc old_vcs in
-    Vcs_.NodeSet.iter (fun id ->
+    Stateid.Set.iter (fun id ->
         match (Vcs_aux.visit old_vcs id).step with
         | `Qed ({ fproof = Some (_, cancel_switch) }, _)
-        | `Cmd { cqueue = `TacQueue cancel_switch }
+        | `Cmd { cqueue = `TacQueue (_,_,cancel_switch) }
         | `Cmd { cqueue = `QueryQueue cancel_switch } ->
              cancel_switch := true
         | _ -> ())
@@ -583,7 +720,10 @@ end = struct (* {{{ *)
 end (* }}} *)
 
 let state_of_id id =
-  try `Valid (VCS.get_info id).state
+  try match (VCS.get_info id).state with
+    | Valid s -> `Valid (Some s)
+    | Error (e,_) -> `Error e
+    | Empty -> `Valid None
   with VCS.Expired -> `Expired
 
 
@@ -603,9 +743,10 @@ module State : sig
 
   val install_cached : Stateid.t -> unit
   val is_cached : ?cache:Summary.marshallable -> Stateid.t -> bool
+  val is_cached_and_valid : ?cache:Summary.marshallable -> Stateid.t -> bool
 
 
-  val exn_on : Stateid.t -> ?valid:Stateid.t -> iexn -> iexn
+  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
@@ -634,10 +775,9 @@ end = struct (* {{{ *)
     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)
+    (fun () -> Obj.magic (freeze_global_state `No, !cur_id))
+    (fun t -> let s,i = Obj.magic t in unfreeze_global_state s; cur_id := i)
   
   type frozen_state = state
   type proof_part =
@@ -649,51 +789,60 @@ end = struct (* {{{ *)
     proof,
     Summary.project_summary (States.summary_of_state system) summary_pstate
 
-  let freeze marshallable id = VCS.set_state id (freeze_global_state marshallable)
+  let freeze marshallable id =
+    VCS.set_state id (Valid (freeze_global_state marshallable))
+  let freeze_invalid id iexn = VCS.set_state id (Error iexn)
 
-  let is_cached ?(cache=`No) id =
+  let is_cached ?(cache=`No) id only_valid =
     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
+        | { state = Empty } when cache = `Yes -> freeze `No id; true
+        | { state = Empty } when cache = `Shallow -> freeze `Shallow id; true
         | _ -> true
       with VCS.Expired -> false
     else
       try match VCS.get_info id with
-        | { state = Some _ } -> true
-        | _ -> false 
+        | { state = Empty } -> false
+        | { state = Valid _ } -> true
+        | { state = Error _ } -> not only_valid
       with VCS.Expired -> false
 
+  let is_cached_and_valid ?cache id = is_cached ?cache id true
+  let is_cached ?cache id = is_cached ?cache id 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
+    match VCS.get_info id with
+    | { state = Valid s } ->
+         if Stateid.equal id !cur_id then () (* optimization *)
+         else begin unfreeze_global_state s; cur_id := id end
+    | { state = Error ie } -> cur_id := id; Exninfo.iraise ie 
+    | _ ->
+        (* coqc has a 1 slot cache and only for valid states *)
+        if interactive () = `No && Stateid.equal id !cur_id then ()
+        else anomaly (str "installing a non cached state")
 
   let get_cached id =
     try match VCS.get_info id with
-    | { state = Some s } -> s
+    | { state = Valid 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
+    if VCS.get_state id <> Empty then () else
     try match what with
     | `Full s ->
          let s =
            try
             let prev = (VCS.visit id).next in
-            if is_cached prev
+            if is_cached_and_valid prev
             then { s with proof = 
               Proof_global.copy_terminators
                 ~src:(get_cached prev).proof ~tgt:s.proof }
             else s
            with VCS.Expired -> s in
-         VCS.set_state id s
+         VCS.set_state id (Valid s)
     | `Proof(ontop,(pstate,counters)) ->
-         if is_cached ontop then
+         if is_cached_and_valid ontop then
            let s = get_cached ontop in
            let s = { s with proof =
              Proof_global.copy_terminators ~src:s.proof ~tgt:pstate } in
@@ -702,17 +851,17 @@ end = struct (* {{{ *)
                (Summary.surgery_summary
                  (States.summary_of_state s.system)
                counters) } in
-           VCS.set_state id s
+           VCS.set_state id (Valid s)
     with VCS.Expired -> ()
 
-  let exn_on id ?valid (e, info) =
+  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)
+        (e, Stateid.add info ~valid id)
 
   let same_env { system = s1 } { system = s2 } =
     let s1 = States.summary_of_state s1 in
@@ -724,12 +873,12 @@ end = struct (* {{{ *)
   let define ?safe_id ?(redefine=false) ?(cache=`No) ?(feedback_processed=true)
         f id
   =
-    feedback ~state_id:id Feedback.(ProcessingIn !Flags.async_proofs_worker_id);
+    feedback ~id:(State id) (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="^
+      prerr_endline (fun () -> "defining "^str_id^" (cache="^
         if cache = `Yes then "Y)" else if cache = `Shallow then "S)" else "N)");
       let good_id = match safe_id with None -> !cur_id | Some id -> id in
       fix_exn_ref := exn_on id ~valid:good_id;
@@ -737,24 +886,27 @@ end = struct (* {{{ *)
       fix_exn_ref := (fun x -> x);
       if cache = `Yes then freeze `No id
       else if cache = `Shallow then freeze `Shallow id;
-      prerr_endline ("setting cur id to "^str_id);
+      prerr_endline (fun () -> "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;
+      VCS.reached id;
       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 (e, info) = CErrors.push e in
       let good_id = !cur_id in
       cur_id := Stateid.dummy;
-      VCS.reached id false;
-      Hooks.(call unreachable_state id (e, info));
-      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)
+      VCS.reached id;
+      let ie =
+        match Stateid.get info, safe_id with
+        | None, None -> (exn_on id ~valid:good_id (e, info))
+        | None, Some good_id -> (exn_on id ~valid:good_id (e, info))
+        | Some _, None -> (e, info)
+        | Some (_,at), Some id -> (e, Stateid.add info ~valid:id at) in
+      if cache = `Yes || cache = `Shallow then freeze_invalid id ie;
+      Hooks.(call unreachable_state id ie);
+      Exninfo.iraise ie
 
 end (* }}} *)
 
@@ -830,7 +982,7 @@ end = struct (* {{{ *)
   let back_safe () =
     let id =
       fold_until (fun n (id,_,_,_,_) ->
-        if n >= 0 && State.is_cached id then `Stop id else `Cont (succ n))
+        if n >= 0 && State.is_cached_and_valid id then `Stop id else `Cont (succ n))
         0 (VCS.get_branch_pos (VCS.current_branch ())) in
     backto id
 
@@ -840,8 +992,6 @@ end = struct (* {{{ *)
       | 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 =
@@ -891,8 +1041,8 @@ end = struct (* {{{ *)
       | _ -> VtUnknown, VtNow
     with
     | Not_found ->
-       msg_warning(str"undo_vernac_classifier: going back to the initial state.");
-       VtStm (VtBack Stateid.initial, true), VtNow
+       CErrors.errorlabstrm "undo_vernac_classifier"
+        (str "Cannot undo")
 
 end (* }}} *)
 
@@ -925,10 +1075,78 @@ let record_pb_time proof_name loc time =
   end
  
 exception RemoteException of std_ppcmds
-let _ = Errors.register_handler (function
+let _ = CErrors.register_handler (function
   | RemoteException ppcmd -> ppcmd
   | _ -> raise Unhandled)
 
+(****************** proof structure for error recovery ************************)
+(******************************************************************************)
+
+type document_node = {
+  indentation : int;
+  ast : Vernacexpr.vernac_expr;
+  id : Stateid.t;
+}
+
+type document_view = {
+  entry_point : document_node;
+  prev_node : document_node -> document_node option;
+}
+
+type static_block_detection =
+  document_view -> static_block_declaration option
+
+type recovery_action = {
+  base_state : Stateid.t;
+  goals_to_admit : Goal.goal list;
+  recovery_command : Vernacexpr.vernac_expr option;
+}
+
+type dynamic_block_error_recovery =
+  static_block_declaration -> [ `ValidBlock of recovery_action | `Leaks ]
+
+let proof_block_delimiters = ref []
+
+let register_proof_block_delimiter name static dynamic =
+  if List.mem_assoc name !proof_block_delimiters then
+    CErrors.errorlabstrm "STM" (str "Duplicate block delimiter " ++ str name);
+  proof_block_delimiters := (name, (static,dynamic)) :: !proof_block_delimiters
+
+let mk_doc_node id = function
+  | { step = `Cmd { ctac; cast = { indentation; expr }}; next } when ctac ->
+       Some { indentation; ast = expr; id }
+  | { step = `Sideff (`Ast ({ indentation; expr }, _)); next } ->
+       Some { indentation; ast = expr; id }
+  | _ -> None
+let prev_node { id } =
+  let id = (VCS.visit id).next in
+  mk_doc_node id (VCS.visit id)
+let cur_node id = mk_doc_node id (VCS.visit id)
+
+let is_block_name_enabled name =
+  match !Flags.async_proofs_tac_error_resilience with
+  | `None -> false
+  | `All -> true
+  | `Only l -> List.mem name l
+
+let detect_proof_block id name =
+  let name = match name with None -> "indent" | Some x -> x in   
+  if is_block_name_enabled name &&
+     (Flags.async_proofs_is_master () || Flags.async_proofs_is_worker ())
+  then (
+  match cur_node id with
+  | None -> ()
+  | Some entry_point -> try
+      let static, _ = List.assoc name !proof_block_delimiters in
+      begin match static { prev_node; entry_point } with
+      | None -> ()
+      | Some ({ block_start; block_stop } as decl) ->
+          VCS.create_proof_block decl name
+      end
+    with Not_found ->
+      CErrors.errorlabstrm "STM"
+        (str "Unknown proof block delimiter " ++ str name)
+  )
 (****************************** THE SCHEDULER *********************************)
 (******************************************************************************)
 
@@ -1034,7 +1252,7 @@ end = struct (* {{{ *)
         try Some (ReqBuildProof ({
           Stateid.exn_info = t_exn_info;
           stop = t_stop;
-          document = VCS.slice ~start:t_start ~stop:t_stop;
+          document = VCS.slice ~block_start:t_start ~block_stop:t_stop;
           loc = t_loc;
           uuid = t_uuid;
           name = t_name }, t_drop, t_states))
@@ -1046,7 +1264,7 @@ end = struct (* {{{ *)
         List.iter (fun (id,s) -> State.assign id s) l; `End
     | `Fresh, BuildProof { t_assign; t_loc; t_name; t_states; t_drop },
               RespBuiltProof (pl, time) ->
-        feedback (Feedback.InProgress ~-1);
+        feedback (InProgress ~-1);
         t_assign (`Val pl);
         record_pb_time t_name t_loc time;
         if !Flags.async_proofs_full || t_drop
@@ -1054,7 +1272,7 @@ end = struct (* {{{ *)
         else `End
     | `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);
+        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);
@@ -1070,7 +1288,7 @@ end = struct (* {{{ *)
         let e = (RemoteException (strbrk s), info) in
         t_assign (`Exn e);
         Hooks.(call execution_error start Loc.ghost (strbrk s));
-        feedback (Feedback.InProgress ~-1)
+        feedback (InProgress ~-1)
 
   let build_proof_here ~drop_pt (id,valid) loc eop =
     Future.create (State.exn_on id ~valid) (fun () ->
@@ -1081,7 +1299,7 @@ end = struct (* {{{ *)
       Aux_file.record_in_aux_at loc "proof_build_time"
         (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1));
       let p = Proof_global.return_proof ~allow_partial:drop_pt () in
-      if drop_pt then Pp.feedback ~state_id:id Feedback.Complete;
+      if drop_pt then feedback ~id:(State id) Complete;
       p)
 
   let perform_buildp { Stateid.exn_info; stop; document; loc } drop my_states =
@@ -1105,30 +1323,31 @@ end = struct (* {{{ *)
             Lemmas.(standard_proof_terminator [] (mk_hook (fun _ _ -> ()))) in
           vernac_interp stop
             ~proof:(pobject, terminator)
-            { verbose = false; loc;
+            { verbose = false; loc; indentation = 0; strlen = 0;
               expr = (VernacEndProof (Proved (Opaque None,None))) }) in
         ignore(Future.join checked_proof);
       end;
       RespBuiltProof(proof,time)
     with
-    | e when Errors.noncritical e || e = Stack_overflow ->
-        let (e, info) = Errors.push e in
+    | e when CErrors.noncritical e || e = Stack_overflow ->
+        let (e, info) = CErrors.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
+        prerr_endline (fun () -> "failed with the following exception:");
+        prerr_endline (fun () -> string_of_ppcmds e_msg);
+        let e_safe_states = List.filter State.is_cached_and_valid my_states in
         RespError { e_error_at; e_safe_id; e_msg; e_safe_states }
   
   let perform_states query =
     if query = [] then [] else
-    let is_tac = function
-      | VernacSolve _ | VernacFocus _ | VernacUnfocus | VernacBullet _ -> true
-      | _ -> false in
+    let is_tac e = match classify_vernac e with
+    | VtProofStep _, _ -> true
+    | _ -> false
+    in
     let initial = 
       let rec aux id =
         try match VCS.visit id with { next } -> aux next
@@ -1138,19 +1357,19 @@ end = struct (* {{{ *)
       let prev =
         try
           let { next = prev; step } = VCS.visit id in
-          if State.is_cached prev && List.mem prev seen
+          if State.is_cached_and_valid 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
+        if State.is_cached_and_valid id then Some (State.get_cached id) else None in
       match prev, this with
       | _, None -> None
       | Some (prev, o, `Cmd { cast = { expr }}), Some n
         when is_tac expr && State.same_env o n -> (* A pure tactic *)
           Some (id, `Proof (prev, State.proof_part_of_frozen n))
       | Some _, Some s ->
-          msg_warning (str "STM: sending back a fat state");
+          msg_debug (str "STM: sending back a fat state");
           Some (id, `Full s)
       | _, Some s -> Some (id, `Full s) in
     let rec aux seen = function
@@ -1173,7 +1392,7 @@ end = struct (* {{{ *)
         "The system state could not be sent to the worker process. "^
         "Falling back to local, lazy, evaluation."));
       t_assign(`Comp(build_proof_here ~drop_pt t_exn_info t_loc t_stop));
-      feedback (Feedback.InProgress ~-1)
+      feedback (InProgress ~-1)
 
 end (* }}} *)
 
@@ -1183,7 +1402,7 @@ and Slaves : sig
   (* (eventually) remote calls *)
   val build_proof :
     loc:Loc.t -> drop_pt:bool ->
-    exn_info:(Stateid.t * Stateid.t) -> start:Stateid.t -> stop:Stateid.t ->
+    exn_info:(Stateid.t * Stateid.t) -> block_start:Stateid.t -> block_stop:Stateid.t ->
       name:string -> future_proof * cancel_switch
 
   (* blocking function that waits for the task queue to be empty *)
@@ -1221,8 +1440,8 @@ end = struct (* {{{ *)
 
   let check_task_aux extra name l i =
     let { Stateid.stop; document; loc; name = r_name }, drop = List.nth l i in
-    msg_info(
-      str(Printf.sprintf "Checking task %d (%s%s) of %s" i r_name extra name));
+    Flags.if_verbose 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 =
@@ -1245,15 +1464,15 @@ end = struct (* {{{ *)
        * 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;
+        { verbose = false; loc; indentation = 0; strlen = 0;
           expr = (VernacEndProof (Proved (Opaque None,None))) };
       `OK proof
       end
     with e ->
-      let (e, info) = Errors.push e in
+      let (e, info) = CErrors.push e in
       (try match Stateid.get info with
       | None ->
-          pperrnl (
+          msg_error (
             str"File " ++ str name ++ str ": proof of " ++ str r_name ++
             spc () ++ iprint (e, info))
       | Some (_, cur) ->
@@ -1263,12 +1482,12 @@ end = struct (* {{{ *)
           | { step = `Qed ( { qast = { loc } }, _) } 
           | { step = `Sideff (`Ast ( { loc }, _)) } ->
               let start, stop = Loc.unloc loc in
-              pperrnl (
+              msg_error (
                 str"File " ++ str name ++ str ": proof of " ++ str r_name ++
                 str ": chars " ++ int start ++ str "-" ++ int stop ++
                 spc () ++ iprint (e, info))
           | _ ->
-              pperrnl (
+              msg_error (
                 str"File " ++ str name ++ str ": proof of " ++ str r_name ++
                 spc () ++ iprint (e, info))
     with e ->
@@ -1328,7 +1547,6 @@ end = struct (* {{{ *)
   let set_perspective idl =
     ProofTask.set_perspective idl;
     TaskQueue.broadcast (Option.get !queue);
-    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
@@ -1343,7 +1561,7 @@ end = struct (* {{{ *)
        BuildProof { t_states = s2 } -> overlap_rel s1 s2
      | _ -> 0)
 
-  let build_proof ~loc ~drop_pt ~exn_info ~start ~stop ~name:pname =
+  let build_proof ~loc ~drop_pt ~exn_info ~block_start ~block_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
@@ -1352,21 +1570,21 @@ end = struct (* {{{ *)
          Future.create_delegate ~blocking:true ~name:pname (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_drop = drop_pt;
+          t_exn_info; t_start = block_start; t_stop = block_stop; t_drop = drop_pt;
           t_assign = assign; t_loc = loc; t_uuid; t_name = pname;
-          t_states = VCS.nodes_in_slice ~start ~stop }) in
+          t_states = VCS.nodes_in_slice ~block_start ~block_stop }) in
         TaskQueue.enqueue_task (Option.get !queue) (task,cancel_switch);
         f, cancel_switch
       end else
-        ProofTask.build_proof_here ~drop_pt t_exn_info loc stop, cancel_switch
+        ProofTask.build_proof_here ~drop_pt t_exn_info loc block_stop, cancel_switch
     else 
       let f, t_assign = Future.create_delegate ~name:pname (State.exn_on id ~valid) in
       let t_uuid = Future.uuid f in
-      feedback (Feedback.InProgress 1);
+      feedback (InProgress 1);
       let task = ProofTask.(BuildProof {
-        t_exn_info; t_start = start; t_stop = stop; t_assign; t_drop = drop_pt;
+        t_exn_info; t_start = block_start; t_stop = block_stop; t_assign; t_drop = drop_pt;
         t_loc = loc; t_uuid; t_name = pname;
-        t_states = VCS.nodes_in_slice ~start ~stop }) in
+        t_states = VCS.nodes_in_slice ~block_start ~block_stop }) in
       TaskQueue.enqueue_task (Option.get !queue) (task,cancel_switch);
       f, cancel_switch
 
@@ -1385,7 +1603,7 @@ end = struct (* {{{ *)
              | Some (ReqBuildProof (r, b, _)) -> Some(r, b)
              | _ -> None)
         tasks in
-    prerr_endline (Printf.sprintf "dumping %d tasks\n" (List.length reqs));
+    prerr_endline (fun () -> Printf.sprintf "dumping %d tasks\n" (List.length reqs));
     reqs
 
   let reset_task_queue () = TaskQueue.clear (Option.get !queue)
@@ -1399,10 +1617,11 @@ and TacTask : sig
     t_state    : Stateid.t;
     t_state_fb : Stateid.t;
     t_assign   : output Future.assignement -> unit;
-    t_ast      : ast;
+    t_ast      : int * aast;
     t_goal     : Goal.goal;
     t_kill     : unit -> unit;
     t_name     : string }  
+  exception NoProgress
 
   include AsyncTaskQueue.Task with type task := task
 
@@ -1416,7 +1635,7 @@ end = struct (* {{{ *)
     t_state    : Stateid.t;
     t_state_fb : Stateid.t;
     t_assign   : output Future.assignement -> unit;
-    t_ast      : ast;
+    t_ast      : int * aast;
     t_goal     : Goal.goal;
     t_kill     : unit -> unit;
     t_name     : string }  
@@ -1425,13 +1644,15 @@ end = struct (* {{{ *)
     r_state    : Stateid.t;
     r_state_fb : Stateid.t;
     r_document : VCS.vcs option;
-    r_ast      : ast;
+    r_ast      : int * aast;
     r_goal     : Goal.goal;
     r_name     : string }
 
   type response =
     | RespBuiltSubProof of output
     | RespError of std_ppcmds
+    | RespNoProgress
+  exception NoProgress
 
   let name = ref "tacworker"
   let extra_env () = [||]
@@ -1445,7 +1666,7 @@ end = struct (* {{{ *)
       r_state_fb = t_state_fb;
       r_document =
         if age <> `Fresh then None
-        else Some (VCS.slice ~start:t_state ~stop:t_state);
+        else Some (VCS.slice ~block_start:t_state ~block_stop:t_state);
       r_ast      = t_ast;
       r_goal     = t_goal;
       r_name     = t_name }
@@ -1454,9 +1675,13 @@ end = struct (* {{{ *)
   let use_response _ { t_assign; t_state; t_state_fb; t_kill } resp =
     match resp with
     | RespBuiltSubProof o -> t_assign (`Val o); `Stay ((),[])
+    | RespNoProgress ->
+        let e = (NoProgress, Exninfo.null) in
+        t_assign (`Exn e);
+        t_kill ();
+        `Stay ((),[])
     | RespError msg ->
-        let info = Stateid.add ~valid:t_state Exninfo.null t_state_fb in
-        let e = (RemoteException msg, info) in
+        let e = (RemoteException msg, Exninfo.null) in
         t_assign (`Exn e);
         t_kill ();
         `Stay ((),[])
@@ -1469,36 +1694,37 @@ end = struct (* {{{ *)
     | Some { t_kill } -> t_kill ()
     | _ -> ()
  
+  let command_focus = Proof.new_focus_kind ()
+  let focus_cond = Proof.no_cond command_focus
+
   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 () ->
+      Future.purify (fun () ->
        let _,_,_,_,sigma0 = Proof.proof (Proof_global.give_me_the_proof ()) in
        let g = Evd.find sigma0 r_goal in
        if not (
          Evarutil.is_ground_term sigma0 Evd.(evar_concl g) &&
-         List.for_all (fun (_,bo,ty) ->
-            Evarutil.is_ground_term sigma0 ty &&
-            Option.cata (Evarutil.is_ground_term sigma0) true bo)
-           Evd.(evar_context g))
+         List.for_all (Context.Named.Declaration.for_all (Evarutil.is_ground_term sigma0))
+                      Evd.(evar_context g))
        then
-         Errors.errorlabstrm "Stm" (strbrk("the par: goal selector supports ground "^
+         CErrors.errorlabstrm "STM" (strbrk("the par: goal selector supports ground "^
            "goals only"))
        else begin
-        vernac_interp r_state_fb r_ast;
+        let (i, ast) = r_ast in
+        Proof_global.simple_with_current_proof (fun _ p -> Proof.focus focus_cond () i p);
+        vernac_interp r_state_fb 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_empty -> RespNoProgress
         | 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")
+              RespBuiltSubProof (t, Evd.evar_universe_context sigma)
+            else CErrors.errorlabstrm "STM" (str"The solution is not ground")
        end) ()
-     in
-       RespBuiltSubProof (t,uc)
-    with e when Errors.noncritical e -> RespError (Errors.print e)
+    with e when CErrors.noncritical e -> RespError (CErrors.print e)
 
   let name_of_task { t_name } = t_name
   let name_of_request { r_name } = r_name
@@ -1508,19 +1734,22 @@ end (* }}} *)
 and Partac : sig
 
   val vernac_interp :
-    cancel_switch -> int -> Stateid.t -> Stateid.t -> ast -> unit
+    solve:bool -> abstract:bool -> cancel_switch ->
+    int -> Stateid.t -> Stateid.t -> aast ->
+      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 vernac_interp ~solve ~abstract cancel nworkers safe_id id
+    { indentation; verbose; loc; expr = e; strlen }
+  =
+    let e, time, fail =
       let rec find time fail = function
-        | VernacSolve(_,_,re,b) -> re, b, time, fail
-        | VernacTime [_,e] | VernacRedirect (_,[_,e]) -> find true fail e
+        | VernacTime (_,e) | VernacRedirect (_,(_,e)) -> find true fail e
         | VernacFail e -> find time true e
-        | _ -> errorlabstrm "Stm" (str"unsupported") in find false false e in
+        | _ -> e, time, fail 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 ->
@@ -1532,51 +1761,58 @@ end = struct (* {{{ *)
           Future.create_delegate
             ~name:(Printf.sprintf "subgoal %d" i)
             (State.exn_on id ~valid:safe_id) in
-        let t_ast =
-          { verbose;loc;expr = VernacSolve(SelectNth i,None,e,etac) } in
+        let t_ast = (i, { indentation; verbose; loc; expr = e; strlen }) 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)
+            t_kill = (fun () -> if solve then TaskQueue.cancel_all queue) },
+           cancel);
+        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
+        Proofview.(Goal.nf_enter { Goal.enter = fun g ->
+        let gid = Goal.goal g in
+        let f =
+          try List.assoc gid res
+          with Not_found -> CErrors.anomaly(str"Partac: wrong focus") in
+        if not (Future.is_over f) then
+          (* One has failed and cancelled the others, but not this one *)
+          if solve then Tacticals.New.tclZEROMSG
+            (str"Interrupted by the failure of another goal")
+          else tclUNIT ()
+        else
+          let open Notations in
+          try
             let pt, uc = Future.join f in
-            prerr_endline (string_of_ppcmds(hov 0 (
-              str"g=" ++ str gid ++ spc () ++
+            prerr_endline (fun () -> string_of_ppcmds(hov 0 (
+              str"g=" ++ int (Evar.repr 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
+            (if abstract then Tactics.tclABSTRACT None else (fun x -> x))
+              (V82.tactic (Refiner.tclPUSHEVARUNIVCONTEXT uc) <*>
+              Tactics.exact_no_check pt)
+          with TacTask.NoProgress ->
+            if solve then Tacticals.New.tclSOLVE [] else tclUNIT ()
+        })
+      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 }
+  type task = { t_where : Stateid.t; t_for : Stateid.t ; t_what : aast }
   include AsyncTaskQueue.Task with type task := task
 
 end = struct (* {{{ *)
   
   type task =
-    { t_where : Stateid.t; t_for : Stateid.t ; t_what : ast }
+    { t_where : Stateid.t; t_for : Stateid.t ; t_what : aast }
   
   type request =
-    { r_where : Stateid.t ; r_for : Stateid.t ; r_what : ast; r_doc : VCS.vcs }
+    { r_where : Stateid.t ; r_for : Stateid.t ; r_what : aast; r_doc : VCS.vcs }
   type response = unit
 
   let name = ref "queryworker"
@@ -1588,7 +1824,7 @@ end = struct (* {{{ *)
     try Some {
       r_where = t_where;
       r_for   = t_for;
-      r_doc   = VCS.slice ~start:t_where ~stop:t_where;
+      r_doc   = VCS.slice ~block_start:t_where ~block_stop:t_where;
       r_what  = t_what }
     with VCS.Expired -> None
   
@@ -1608,11 +1844,11 @@ end = struct (* {{{ *)
     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 e = Errors.push e in
-      let msg = string_of_ppcmds (iprint e) in
-      feedback ~state_id:r_for (Feedback.ErrorMsg (Loc.ghost, msg))
+      feedback ~id:(State r_for) Processed
+    with e when CErrors.noncritical e ->
+      let e = CErrors.push e in
+      let msg = pp_to_richpp (iprint e) in
+      feedback ~id:(State r_for) (Message (Error, None, 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)
@@ -1622,7 +1858,7 @@ end (* }}} *)
 and Query : sig 
 
   val init : unit -> unit
-  val vernac_interp : cancel_switch -> Stateid.t ->  Stateid.t -> ast -> unit
+  val vernac_interp : cancel_switch -> Stateid.t ->  Stateid.t -> aast -> unit
 
 end = struct (* {{{ *)
 
@@ -1633,7 +1869,7 @@ end = struct (* {{{ *)
   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)
+      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))
@@ -1659,12 +1895,18 @@ let async_policy () =
     (!compilation_mode = BuildVio || !async_proofs_mode <> APoff)
 
 let delegate name =
-  let time = get_hint_bp_time name in
-  time >= 1.0 || !Flags.compilation_mode = Flags.BuildVio
-              || !Flags.async_proofs_full
+     get_hint_bp_time name >= !Flags.async_proofs_delegation_threshold
+  || !Flags.compilation_mode = Flags.BuildVio
+  || !Flags.async_proofs_full
+ 
+let warn_deprecated_nested_proofs =
+  CWarnings.create ~name:"deprecated-nested-proofs" ~category:"deprecated"
+         (fun () ->
+          strbrk ("Nested proofs are deprecated and will "^
+                    "stop working in a future Coq version"))
 
 let collect_proof keep cur hd brkind id =
- prerr_endline ("Collecting proof ending at "^Stateid.to_string id);
+ prerr_endline (fun () -> "Collecting proof ending at "^Stateid.to_string id);
  let no_name = "" in
  let name = function
    | [] -> no_name
@@ -1684,16 +1926,20 @@ let collect_proof keep cur hd brkind id =
  let has_proof_no_using = function
    | Some (_, { expr = VernacProof(_,None) }) -> true
    | _ -> false in
- let may_pierce_opaque = function
-   | { expr = VernacPrint (PrintName _) } -> true
-   | _ -> false in
+ let too_complex_to_delegate = function
+   | { expr = (VernacDeclareModule _
+              | VernacDefineModule _
+              | VernacDeclareModuleType _
+              | VernacInclude _) } -> true
+   | { expr =  (VernacRequire _ | VernacImport _) } -> true
+   | ast -> may_pierce_opaque ast in
  let parent = function Some (p, _) -> p | None -> assert false in
  let is_empty = function `Async(_,_,[],_,_) | `MaybeASync(_,_,[],_,_) -> true | _ -> false in
  let rec collect last accn id =
     let view = VCS.visit id in
     match view.step with
     | (`Sideff (`Ast(x,_)) | `Cmd { cast = x })
-      when may_pierce_opaque x -> `Sync(no_name,None,`Print)
+      when too_complex_to_delegate x -> `Sync(no_name,None,`Print)
     | `Cmd { cast = x } -> collect (Some (id,x)) (id::accn) view.next
     | `Sideff (`Ast(x,_)) -> collect (Some (id,x)) (id::accn) view.next
     (* An Alias could jump everywhere... we hope we can ignore it*)
@@ -1707,7 +1953,7 @@ let collect_proof keep cur hd brkind id =
         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)) &&
+       has_proof_no_using last && not (State.is_cached_and_valid (parent last)) &&
        !Flags.compilation_mode = Flags.BuildVio ->
         assert (VCS.Branch.equal hd hd'||VCS.Branch.equal hd VCS.edit_branch);
         (try
@@ -1723,8 +1969,7 @@ let collect_proof keep cur hd brkind id =
         let name = name ids in
         `MaybeASync (parent last, None, accn, name, delegate name)
     | `Sideff _ ->
-        Pp.(msg_warning (strbrk ("Nested proofs are deprecated and will "^
-           "stop working in the next Coq version")));
+       warn_deprecated_nested_proofs ();
         `Sync (no_name,None,`NestedProof)
     | _ -> `Sync (no_name,None,`Unknown) in
  let make_sync why = function
@@ -1743,7 +1988,7 @@ let collect_proof keep cur hd brkind id =
        let rc = collect (Some cur) [] id in
        if is_empty rc then make_sync `AlreadyEvaluated rc
        else if (keep == VtKeep || keep == VtKeepAsAxiom) &&
-          (not(State.is_cached id) || !Flags.async_proofs_full)
+          (not(State.is_cached_and_valid id) || !Flags.async_proofs_full)
        then check_policy rc
        else make_sync `AlreadyEvaluated rc
 
@@ -1761,7 +2006,7 @@ let string_of_reason = function
   | `NoPU_NoHint_NoES -> "no 'Proof using..', no .aux file, inside a section"
   | `Unknown -> "unsupported case"
 
-let log_string s = prerr_debug ("STM: " ^ s)
+let log_string s = prerr_debug (fun () -> "STM: " ^ s)
 let log_processing_async id name = log_string Printf.(sprintf
   "%s: proof %s: asynch" (Stateid.to_string id) name
 )
@@ -1773,6 +2018,71 @@ let log_processing_sync id name reason = log_string Printf.(sprintf
 let wall_clock_last_fork = ref 0.0
 
 let known_state ?(redefine_qed=false) ~cache id =
+ 
+  let error_absorbing_tactic id blockname exn =
+    (* We keep the static/dynamic part of block detection separate, since
+       the static part could be performed earlier.  As of today there is
+       no advantage in doing so since no UI can exploit such piece of info *)
+    detect_proof_block id blockname;
+
+    let boxes = VCS.box_of id in
+    let valid_boxes = CList.map_filter (function
+      | ProofBlock ({ block_stop } as decl, name) when Stateid.equal block_stop id ->
+          Some (decl, name)
+      | _ -> None) boxes in
+    assert(List.length valid_boxes < 2);
+    if valid_boxes = [] then iraise exn
+    else
+      let decl, name = List.hd valid_boxes in
+      try
+        let _, dynamic_check = List.assoc name !proof_block_delimiters in
+        match dynamic_check decl with
+        | `Leaks -> iraise exn
+        | `ValidBlock { base_state; goals_to_admit; recovery_command } -> begin
+           let tac =
+             let open Proofview.Notations in
+             Proofview.Goal.nf_enter { enter = fun gl ->
+               if CList.mem_f Evar.equal
+                 (Proofview.Goal.goal gl) goals_to_admit then
+             Proofview.give_up else Proofview.tclUNIT ()
+               } in
+           match (VCS.get_info base_state).state with
+           | Valid { proof } ->
+               Proof_global.unfreeze proof;
+               Proof_global.with_current_proof (fun _ p ->
+                 feedback ~id:(State id) Feedback.AddedAxiom;
+                 fst (Pfedit.solve Vernacexpr.SelectAll None tac p), ());
+               Option.iter (fun expr -> vernac_interp id {
+                  verbose = true; loc = Loc.ghost; expr; indentation = 0;
+                  strlen = 0 })
+               recovery_command
+           | _ -> assert false
+        end
+      with Not_found ->
+          CErrors.errorlabstrm "STM"
+            (str "Unknown proof block delimiter " ++ str name)
+  in
+
+  (* Absorb tactic errors from f () *)
+  let resilient_tactic id blockname f =
+    if !Flags.async_proofs_tac_error_resilience = `None ||
+       (Flags.async_proofs_is_master () &&
+        !Flags.async_proofs_mode = Flags.APoff)
+    then f ()
+    else
+      try f ()
+      with e when CErrors.noncritical e ->
+        let ie = CErrors.push e in
+        error_absorbing_tactic id blockname ie in
+  (* Absorb errors from f x *)
+  let resilient_command f x =
+    if not !Flags.async_proofs_cmd_error_resilience ||
+       (Flags.async_proofs_is_master () &&
+        !Flags.async_proofs_mode = Flags.APoff)
+    then f x
+    else
+      try f x
+      with e when CErrors.noncritical e -> () in
 
   (* ugly functions to process nested lemmas, i.e. hard to reproduce
    * side effects *)
@@ -1782,18 +2092,18 @@ let known_state ?(redefine_qed=false) ~cache id =
   let inject_non_pstate (s,l) =
     Summary.unfreeze_summary s; Lib.unfreeze l; update_global_env ()
   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;
+  let rec pure_cherry_pick_non_pstate safe_id id = Future.purify (fun id ->
+    prerr_endline (fun () -> "cherry-pick non pstate " ^ Stateid.to_string id);
+    reach ~safe_id 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);
+  and reach ?safe_id ?(redefine_qed=false) ?(cache=cache) id =
+    prerr_endline (fun () -> "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)")
+      prerr_endline (fun () -> "reached (cache)");
+      State.install_cached id
     end else
     let step, cache_step, feedback_processed =
       let view = VCS.visit id in
@@ -1801,46 +2111,58 @@ let known_state ?(redefine_qed=false) ~cache id =
       | `Alias (id,_) -> (fun () ->
             reach view.next; reach id
           ), cache, true
-      | `Cmd { cast = x; cqueue = `TacQueue cancel } -> (fun () ->
-            reach ~cache:`Shallow view.next;
-            Hooks.(call tactic_being_run true); 
-            Partac.vernac_interp
-              cancel !Flags.async_proofs_n_tacworkers view.next id x;
-            Hooks.(call tactic_being_run false)
+      | `Cmd { cast = x; cqueue = `SkipQueue } -> (fun () ->
+            reach view.next), cache, true
+      | `Cmd { cast = x; cqueue = `TacQueue (solve,abstract,cancel); cblock } ->
+          (fun () ->
+            resilient_tactic id cblock (fun () ->
+              reach ~cache:`Shallow view.next;
+              Hooks.(call tactic_being_run true); 
+              Partac.vernac_interp ~solve ~abstract
+                cancel !Flags.async_proofs_n_tacworkers view.next id x;
+              Hooks.(call tactic_being_run false))
           ), cache, true
       | `Cmd { cast = x; cqueue = `QueryQueue cancel }
         when Flags.async_proofs_is_master () -> (fun () ->
             reach view.next;
             Query.vernac_interp cancel view.next id x
           ), cache, false
-      | `Cmd { cast = x; ceff = eff; ctac } -> (fun () ->
-            reach view.next;
-            if ctac then Hooks.(call tactic_being_run true); 
+      | `Cmd { cast = x; ceff = eff; ctac = true; cblock } -> (fun () ->
+            resilient_tactic id cblock (fun () ->
+              reach view.next;
+              Hooks.(call tactic_being_run true); 
+              vernac_interp id x;
+              Hooks.(call tactic_being_run false)); 
+	    if eff then update_global_env ()
+          ), (if eff then `Yes else cache), true
+      | `Cmd { cast = x; ceff = eff } -> (fun () ->
+            resilient_command reach view.next;
             vernac_interp id x;
-            if ctac then Hooks.(call tactic_being_run false); 
-	    if eff then update_global_env ()), cache, true
+	    if eff then update_global_env ()
+          ), (if eff then `Yes else cache), true
       | `Fork ((x,_,_,_), None) -> (fun () ->
-            reach view.next; vernac_interp id x;
+            resilient_command reach view.next;
+            vernac_interp id x;
             wall_clock_last_fork := Unix.gettimeofday ()
           ), `Yes, true
-      | `Fork ((x,_,_,_), Some prev) -> (fun () ->
+      | `Fork ((x,_,_,_), Some prev) -> (fun () -> (* nested proof *)
             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
+            with e when CErrors.noncritical e ->
+              let (e, info) = CErrors.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 () ->
+          | `ASync (block_start, pua, nodes, name, delegate) -> (fun () ->
                 assert(keep == VtKeep || keep == VtKeepAsAxiom);
                 let drop_pt = keep == VtKeepAsAxiom in
-                let stop, exn_info, loc = eop, (id, eop), x.loc in
+                let block_stop, exn_info, loc = eop, (id, eop), x.loc in
                 log_processing_async id name;
-                VCS.create_cluster nodes ~qed:id ~start;
+                VCS.create_proof_task_box nodes ~qed:id ~block_start;
                 begin match brinfo, qed.fproof with
                 | { VCS.kind = `Edit _ }, None -> assert false
                 | { VCS.kind = `Edit (_,_,_, okeep, _) }, Some (ofp, cancel) ->
@@ -1854,19 +2176,22 @@ let known_state ?(redefine_qed=false) ~cache id =
                         ^"the proof's statement to avoid that."));
                     let fp, cancel =
                       Slaves.build_proof
-                        ~loc ~drop_pt ~exn_info ~start ~stop ~name in
+                        ~loc ~drop_pt ~exn_info ~block_start ~block_stop ~name in
                     Future.replace ofp fp;
-                    qed.fproof <- Some (fp, cancel)
+                    qed.fproof <- Some (fp, cancel);
+                    (* We don't generate a new state, but we still need
+                     * to install the right one *)
+                    State.install_cached id
                 | { VCS.kind = `Proof _ }, Some _ -> assert false
                 | { VCS.kind = `Proof _ }, None ->
-                    reach ~cache:`Shallow start;
+                    reach ~cache:`Shallow block_start;
                     let fp, cancel =
                       if delegate then
                         Slaves.build_proof
-                          ~loc ~drop_pt ~exn_info ~start ~stop ~name
+                          ~loc ~drop_pt ~exn_info ~block_start ~block_stop ~name
                       else
                         ProofTask.build_proof_here
-                          ~drop_pt exn_info loc stop, ref false
+                          ~drop_pt exn_info loc block_stop, ref false
                     in
                     qed.fproof <- Some (fp, cancel);
                     let proof =
@@ -1874,7 +2199,7 @@ let known_state ?(redefine_qed=false) ~cache id =
                     if not delegate then ignore(Future.compute fp);
                     reach view.next;
                     vernac_interp id ~proof x;
-                    feedback ~state_id:id Feedback.Incomplete
+                    feedback ~id:(State id) Incomplete
                 | { VCS.kind = `Master }, _ -> assert false
                 end;
                 Proof_global.discard_all ()
@@ -1921,15 +2246,15 @@ let known_state ?(redefine_qed=false) ~cache id =
           ), cache, true
       | `Sideff (`Id origin) -> (fun () ->
             reach view.next;
-            inject_non_pstate (pure_cherry_pick_non_pstate origin);
+            inject_non_pstate (pure_cherry_pick_non_pstate view.next origin);
           ), cache, true
     in
     let cache_step =
       if !Flags.async_proofs_cache = Some Flags.Force then `Yes
       else cache_step in
-    State.define
+    State.define ?safe_id
       ~cache:cache_step ~redefine:redefine_qed ~feedback_processed step id;
-    prerr_endline ("reached: "^ Stateid.to_string id) in
+    prerr_endline (fun () -> "reached: "^ Stateid.to_string id) in
   reach ~redefine_qed id
 
 end (* }}} *)
@@ -1944,7 +2269,7 @@ let init () =
   Backtrack.record ();
   Slaves.init ();
   if Flags.async_proofs_is_master () then begin
-    prerr_endline "Initializing workers";
+    prerr_endline (fun () -> "Initializing workers");
     Query.init ();
     let opts = match !Flags.async_proofs_private_flags with
       | None -> []
@@ -1963,7 +2288,7 @@ let observe id =
     Reach.known_state ~cache:(interactive ()) id;
     VCS.print ()
   with e ->
-    let e = Errors.push e in
+    let e = CErrors.push e in
     VCS.print ();
     VCS.restore vcs;
     iraise e
@@ -1996,9 +2321,9 @@ let rec join_admitted_proofs id =
 let join () =
   finish ();
   wait ();
-  prerr_endline "Joining the environment";
+  prerr_endline (fun () -> "Joining the environment");
   Global.join_safe_environment ();
-  prerr_endline "Joining Admitted proofs";
+  prerr_endline (fun () -> "Joining Admitted proofs");
   join_admitted_proofs (VCS.get_branch_pos (VCS.current_branch ()));
   VCS.print ();
   VCS.print ()
@@ -2011,28 +2336,26 @@ let check_task name (tasks,rcbackup) i =
   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
+  with e when CErrors.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);
+    let e = CErrors.push e in
+    msg_error (str"File " ++ str name ++ str ":" ++ spc () ++ iprint e);
     exit 1
 
-let merge_proof_branch ?valid ?id qast keep brname =
+let merge_proof_branch ~valid ?id qast keep brname =
   let brinfo = VCS.get_branch brname in
   let qed fproof = { qast; keep; brname; brinfo; fproof } in
   match brinfo with
@@ -2041,7 +2364,7 @@ let merge_proof_branch ?valid ?id qast keep brname =
       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;
+      VCS.propagate_sideff None;
       `Ok
   | { VCS.kind = `Edit (mode, qed_id, master_id, _,_) } ->
       let ofp =
@@ -2055,12 +2378,12 @@ let merge_proof_branch ?valid ?id qast keep brname =
       VCS.checkout VCS.Branch.master;
       `Unfocus qed_id
   | { VCS.kind = `Master } ->
-       iraise (State.exn_on ?valid Stateid.dummy (Proof_global.NoCurrentProof, Exninfo.null))
+       iraise (State.exn_on ~valid 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
+  if e = CErrors.Drop then iraise (e, info) else
   match Stateid.get info with
   | None ->
       VCS.restore vcs;
@@ -2072,9 +2395,9 @@ let handle_failure (e, info) vcs tty =
       end;
       VCS.print ();
       anomaly(str"error with no safe_id attached:" ++ spc() ++
-        Errors.iprint_no_report (e, info))
+        CErrors.iprint_no_report (e, info))
   | Some (safe_id, id) ->
-      prerr_endline ("Failed at state " ^ Stateid.to_string id);
+      prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id);
       VCS.restore vcs;
       if tty && interactive () = `Yes then begin
         (* We stay on a valid state *)
@@ -2085,38 +2408,37 @@ let handle_failure (e, info) vcs tty =
       VCS.print ();
       iraise (e, info)
 
-let snapshot_vio ldir long_f_dot_v =
+let snapshot_vio ldir long_f_dot_vo =
   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
+    CErrors.errorlabstrm "stm" (str"Cannot dump a vio with open proofs");
+  Library.save_library_to ~todo:(dump_snapshot ()) ldir long_f_dot_vo
     (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 process_transaction ?(newtip=Stateid.fresh ()) ~tty
+  ({ verbose; loc; expr } as x) c =
+  prerr_endline (fun () -> "{{{ 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);
+      prerr_endline (fun () ->
+        "  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 (VtJoinDocument, b), VtNow -> join (); `Ok
+      | VtStm (VtFinish, b),       VtNow -> finish (); `Ok
+      | VtStm (VtWait, b),     VtNow -> 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
+          VCS.print ~now:true (); `Ok
+      | VtStm (VtObserve id, b),   VtNow -> observe id; `Ok
       | VtStm ((VtObserve _ | VtFinish | VtJoinDocument
                 |VtPrintDag |VtWait),_), VtLater ->
           anomaly(str"classifier: join actions cannot be classified as VtLater")
@@ -2125,9 +2447,10 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) =
       | VtStm (VtBack oid, true), w ->
           let id = VCS.new_node ~id:newtip () in
           let { mine; others } = Backtrack.branches_of oid in
+          let valid = VCS.get_branch_pos head in
           List.iter (fun branch ->
             if not (List.mem_assoc branch (mine::others)) then
-              ignore(merge_proof_branch x VtDrop branch))
+              ignore(merge_proof_branch ~valid x VtDrop branch))
             (VCS.branches ());
           VCS.checkout_shallowest_proof_branch ();
           let head = VCS.current_branch () in
@@ -2141,7 +2464,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) =
           VCS.commit id (Alias (oid,x));
           Backtrack.record (); if w == VtNow then finish (); `Ok
       | VtStm (VtBack id, false), VtNow ->
-          prerr_endline ("undo to state " ^ Stateid.to_string id);
+          prerr_endline (fun () -> "undo to state " ^ Stateid.to_string id);
           Backtrack.backto id;
           VCS.checkout_shallowest_proof_branch ();
           Reach.known_state ~cache:(interactive ()) id; `Ok
@@ -2152,22 +2475,26 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) =
       | 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
+            {x with verbose = true }
+           with e when CErrors.noncritical e ->
+             let e = CErrors.push e in
+             iraise (State.exn_on ~valid:Stateid.dummy report_id e)); `Ok
       | VtQuery (false,(report_id,route)), VtNow ->
           (try vernac_interp report_id ~route x
            with e ->
-             let e = Errors.push e in
-             iraise (State.exn_on report_id e)); `Ok
+             let e = CErrors.push e in
+             iraise (State.exn_on ~valid:Stateid.dummy 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 if Flags.(!compilation_mode = BuildVio) &&
+                    VCS.((get_branch head).kind = `Master) &&
+                    may_pierce_opaque x
+                 then `SkipQueue 
             else `MainQueue in
-          VCS.commit id (Cmd {ctac=false;ceff=false;cast = x; cids = []; cqueue = queue });
+          VCS.commit id (mkTransCmd x [] false queue);
           Backtrack.record (); if w == VtNow then finish (); `Ok
       | VtQuery (false,_), VtLater ->
           anomaly(str"classifier: VtQuery + VtLater must imply part_of_script")
@@ -2190,7 +2517,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) =
           anomaly(str"VtProofMode must be executed VtNow")
       | VtProofMode mode, VtNow ->
           let id = VCS.new_node ~id:newtip () in
-          VCS.commit id (Cmd {ctac=false;ceff=false;cast = x;cids=[];cqueue = `MainQueue});
+          VCS.commit id (mkTransCmd x [] false `MainQueue);
           List.iter
             (fun bn -> match VCS.get_branch bn with
             | { VCS.root; kind = `Master; pos } -> ()
@@ -2205,14 +2532,21 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) =
           Backtrack.record ();
           finish ();
           `Ok
-      | VtProofStep paral, w ->
+      | VtProofStep { parallel; proof_block_detection = cblock }, w ->
           let id = VCS.new_node ~id:newtip () in
-          let queue = if paral then `TacQueue (ref false) else `MainQueue in
-          VCS.commit id (Cmd {ctac = true;ceff = false;cast = x;cids = [];cqueue = queue });
+          let queue =
+            match parallel with
+            | `Yes(solve,abstract) -> `TacQueue (solve, abstract, ref false)
+            | `No -> `MainQueue in
+          VCS.commit id (mkTransTac x cblock queue);
+          (* Static proof block detection delayed until an error really occurs.
+             If/when and UI will make something useful with this piece of info,
+             detection should occur here.
+          detect_proof_block id cblock; *)
           Backtrack.record (); if w == VtNow then finish (); `Ok
       | VtQed keep, w ->
-          let valid = if tty then Some(VCS.get_branch_pos head) else None in
-          let rc = merge_proof_branch ?valid ~id:newtip x keep head in
+          let valid = VCS.get_branch_pos head in
+          let rc = merge_proof_branch ~valid ~id:newtip x keep head in
           VCS.checkout_shallowest_proof_branch ();
           Backtrack.record (); if w == VtNow then finish ();
           rc
@@ -2222,15 +2556,22 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) =
           vernac_interp (VCS.get_branch_pos head) x; `Ok
 
       | VtSideff l, w ->
+          let in_proof = not (VCS.Branch.equal head VCS.Branch.master) in
           let id = VCS.new_node ~id:newtip () in
           VCS.checkout VCS.Branch.master;
-          VCS.commit id (Cmd {ctac=false;ceff=true;cast=x;cids=l;cqueue=`MainQueue});
-          VCS.propagate_sideff (Some x);
+          VCS.commit id (mkTransCmd x l in_proof `MainQueue);
+          (* We can't replay a Definition since universes may be differently
+           * inferred.  This holds in Coq >= 8.5 *)
+	  let replay = match x.expr with
+	    | VernacDefinition(_, _, DefineBody _) -> None
+	    | _ -> Some x in
+	  VCS.propagate_sideff ~replay;
           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 in_proof = not (VCS.Branch.equal head VCS.Branch.master) in
           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 *)
@@ -2240,17 +2581,22 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) =
             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
+            if not in_proof && 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";
+              let opacity_of_produced_term =
+                match x.expr with
+                (* This AST is ambiguous, hence we check it dynamically *)
+                | VernacInstance (false, _,_ , None, _) -> GuaranteesOpacity
+                | _ -> Doesn'tGuaranteeOpacity in
+              VCS.commit id (Fork (x,bname,opacity_of_produced_term,[]));
+              let proof_mode = default_proof_mode () in
+              VCS.branch bname (`Proof (proof_mode, VCS.proof_nesting () + 1));
+              Proof_global.activate_proof_mode proof_mode;
             end else begin
-	      VCS.commit id (Cmd {ctac = false; ceff = true;
-				    cast = x; cids = []; cqueue = `MainQueue});
-              VCS.propagate_sideff (Some x);
+              VCS.commit id (mkTransCmd x [] in_proof `MainQueue);
+              (* We hope it can be replayed, but we can't really know *)
+              VCS.propagate_sideff ~replay:(Some x);
               VCS.checkout_shallowest_proof_branch ();
             end in
           State.define ~safe_id:head_id ~cache:`Yes step id;
@@ -2260,49 +2606,56 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) =
           anomaly(str"classifier: VtUnknown must imply VtNow")
     end in
     (* Proof General *)
-    begin match v with 
+    begin match expr with 
       | VernacStm (PGLast _) ->
         if not (VCS.Branch.equal head VCS.Branch.master) then
           vernac_interp Stateid.dummy
-            { verbose = true; loc = Loc.ghost;
+            { verbose = true; loc = Loc.ghost; indentation = 0; strlen = 0;
               expr = VernacShow (ShowGoal OpenSubgoals) }
       | _ -> ()
     end;
-    prerr_endline "processed }}}";
+    prerr_endline (fun () -> "processed }}}");
     VCS.print ();
     rc
   with e ->
-    let e = Errors.push e in
+    let e = CErrors.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 get_ast id =
+  match VCS.visit id with
+  | { step = `Cmd { cast = { loc; expr } } }
+  | { step = `Fork (({ loc; expr }, _, _, _), _) } 
+  | { step = `Qed ({ qast = { loc; expr } }, _) } ->
+         Some (expr, loc)
+  | _ -> None
 
 let stop_worker n = Slaves.cancel_worker n
 
+(* You may need to know the len + indentation of previous command to compute
+ * the indentation of the current one.
+ *  Eg.   foo. bar.
+ * Here bar is indented of the indentation of foo + its strlen (4) *)
+let ind_len_of id =
+  if Stateid.equal id Stateid.initial then 0
+  else match (VCS.visit id).step with
+  | `Cmd { ctac = true; cast = { indentation; strlen } } ->
+       indentation + strlen
+  | _ -> 0
+
 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
+  if not (Stateid.equal ontop cur_tip) then
     (* For now, arbitrary edits should be announced with edit_at *)
-    anomaly(str"Not yet implemented, the GUI should not try this")
-  end
+    anomaly(str"Not yet implemented, the GUI should not try this");
+  let indentation, strlen, loc, ast =
+    vernac_parse ~indlen_prev:(fun () -> ind_len_of ontop) ?newtip eid s in
+  CWarnings.set_current_loc loc;
+  check(loc,ast);
+  let clas = classify_vernac ast in
+  let aast = { verbose = verb; indentation; strlen; loc; expr = ast } in
+  match process_transaction ?newtip ~tty:false aast clas with
+  | `Ok -> VCS.cur_tip (), `NewTip
+  | `Unfocus qed_id -> qed_id, `Unfocus (VCS.cur_tip ())
 
 let set_perspective id_list = Slaves.set_perspective id_list
 
@@ -2312,20 +2665,21 @@ type focus = {
   tip : Stateid.t
 }
 
-let query ~at ?(report_with=(Stateid.dummy,Feedback.default_route)) s =
+let query ~at ?(report_with=(Stateid.dummy,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 indentation, strlen, loc, ast = vernac_parse ~newtip ~route 0 s in
+    CWarnings.set_current_loc loc;
     let clas = classify_vernac ast in
+    let aast = { verbose = true; indentation; strlen; loc; expr = ast } in
     match clas with
     | VtStm (w,_), _ ->
-       ignore(process_transaction
-         ~tty:false true (VtStm (w,false), VtNow) loc_ast)
+       ignore(process_transaction ~tty:false aast (VtStm (w,false), VtNow))
     | _ ->
        ignore(process_transaction
-         ~tty:false true (VtQuery (false,report_with), VtNow) loc_ast))
+         ~tty:false aast (VtQuery (false,report_with), VtNow)))
   s
 
 let edit_at id =
@@ -2350,7 +2704,7 @@ let edit_at id =
     | _ -> assert false
   in
   let is_ancestor_of_cur_branch id =
-    Vcs_.NodeSet.mem id
+    Stateid.Set.mem id
       (VCS.reachable (VCS.get_branch_pos (VCS.current_branch ()))) in
   let has_failed qed_id =
     match VCS.visit qed_id with
@@ -2365,13 +2719,13 @@ let edit_at id =
       | { next } -> master_for_br root next in
   let reopen_branch start at_id mode qed_id tip old_branch =
     let master_id, cancel_switch, keep =
-      (* Hum, this should be the real start_id in the clusted and not next *)
+      (* Hum, this should be the real start_id in the cluster and not next *)
       match VCS.visit qed_id with
       | { step = `Qed ({ fproof = Some (_,cs); keep },_) } -> start, cs, keep
-      | _ -> anomaly (str "Cluster not ending with Qed") in
+      | _ -> anomaly (str "ProofTask not ending with Qed") in
     VCS.branch ~root:master_id ~pos:id
       VCS.edit_branch (`Edit (mode, qed_id, master_id, keep, old_branch));
-    VCS.delete_cluster_of id;
+    VCS.delete_boxes_of id;
     cancel_switch := true;
     Reach.known_state ~cache:(interactive ()) id;
     VCS.checkout_shallowest_proof_branch ();
@@ -2385,14 +2739,14 @@ let edit_at id =
     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
+         Stateid.Set.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
       (Option.default brname bn)
       (no_edit brinfo.VCS.kind);
-    VCS.delete_cluster_of id;
+    VCS.delete_boxes_of id;
     VCS.gc ();
     VCS.print ();
     if not !Flags.async_proofs_full then
@@ -2407,14 +2761,14 @@ let edit_at id =
         | Some{ mine = bn, { VCS.kind = `Proof(m,_) }} -> Some(m,bn)
         | Some{ mine = _, { VCS.kind = `Edit(m,_,_,_,bn) }} -> Some (m,bn)
         | _ -> None in
-      match focused, VCS.cluster_of id, branch_info with
+      match focused, VCS.proof_task_box_of id, branch_info with
       | _, Some _, None -> assert false
-      | false, Some (qed_id,start), Some(mode,bn) ->
+      | false, Some { qed = qed_id ; lemma = start }, Some(mode,bn) ->
           let tip = VCS.cur_tip () in
           if has_failed qed_id && is_pure qed_id && not !Flags.async_proofs_never_reopen_branch
           then reopen_branch start id mode qed_id tip bn
           else backto id (Some bn)
-      | true, Some (qed_id,_), Some(mode,bn) ->
+      | true, Some { qed = qed_id }, Some(mode,bn) ->
           if on_cur_branch id then begin
             assert false
           end else if is_ancestor_of_cur_branch id then begin
@@ -2439,14 +2793,14 @@ let edit_at id =
     VCS.print ();
     rc
   with e ->
-    let (e, info) = Errors.push e in
+    let (e, info) = CErrors.push e in
     match Stateid.get info with
     | None ->
         VCS.print ();
         anomaly (str ("edit_at "^Stateid.to_string id^": ") ++
-          Errors.print_no_report e)
+          CErrors.print_no_report e)
     | Some (_, id) ->
-        prerr_endline ("Failed at state " ^ Stateid.to_string id);
+        prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id);
         VCS.restore vcs;
         VCS.print ();
         iraise (e, info)
@@ -2457,9 +2811,10 @@ let restore d = VCS.restore d
 (*********************** TTY API (PG, coqtop, coqc) ***************************)
 (******************************************************************************)
 
-let interp verb (_,e as lexpr) =
+let interp verb (loc,e) =
   let clas = classify_vernac e in
-  let rc = process_transaction ~tty:true verb clas lexpr in
+  let aast = { verbose = verb; indentation = 0; strlen = 0; loc; expr = e } in
+  let rc = process_transaction ~tty:true aast clas 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 &&
@@ -2472,7 +2827,7 @@ let interp verb (_,e as lexpr) =
        | _ -> not !Flags.coqtop_ui in
     try finish ~print_goals ()
     with e ->
-      let e = Errors.push e in
+      let e = CErrors.push e in
       handle_failure e vcs true
 
 let finish () = finish ()
diff --git a/stm/stm.mli b/stm/stm.mli
index ad89eb71..b8a2a385 100644
--- a/stm/stm.mli
+++ b/stm/stm.mli
@@ -9,6 +9,7 @@
 open Vernacexpr
 open Names
 open Feedback
+open Loc
 
 (** state-transaction-machine interface *)
 
@@ -19,7 +20,9 @@ open Feedback
    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) ->
+val add :
+  ontop:Stateid.t -> ?newtip:Stateid.t ->
+  ?check:(vernac_expr located -> unit) ->
   bool -> edit_id -> string ->
     Stateid.t * [ `NewTip | `Unfocus of Stateid.t ]
 
@@ -75,7 +78,9 @@ val get_current_state : unit -> Stateid.t
 
 (* Misc *)
 val init : unit -> unit
-val print_ast : Stateid.t -> Xml_datatype.xml
+
+(* This returns the node at that position *)
+val get_ast : Stateid.t -> (Vernacexpr.vernac_expr * Loc.t) option
 
 (* Filename *)
 val set_compilation_hints : string -> unit
@@ -93,6 +98,82 @@ module ProofTask : AsyncTaskQueue.Task
 module TacTask   : AsyncTaskQueue.Task
 module QueryTask : AsyncTaskQueue.Task
 
+(** document structure customization *************************************** **)
+
+(* A proof block delimiter defines a syntactic delimiter for sub proofs
+   that, when contain an error, do not impact the rest of the proof.
+   While checking a proof, if an error occurs in a (valid) block then
+   processing can skip the entire block and go on to give feedback
+   on the rest of the proof.
+  
+   static_block_detection and dynamic_block_validation are run when
+   the closing block marker is parsed/executed respectively.
+  
+   static_block_detection is for example called when "}" is parsed and
+   declares a block containing all proof steps between it and the matching
+   "{".
+  
+   dynamic_block_validation is called when an error "crosses" the "}" statement.
+   Depending on the nature of the goal focused by "{" the block may absorb the
+   error or not.  For example if the focused goal occurs in the type of
+   another goal, then the block is leaky.
+   Note that one can design proof commands that need no dynamic validation.
+  
+   Example of document:
+
+      .. { tac1. tac2. } ..
+
+   Corresponding DAG:
+
+      .. (3) <-- { -- (4) <-- tac1 -- (5) <-- tac2 -- (6) <-- } -- (7) ..
+                       
+   Declaration of block  [-------------------------------------------]
+
+      start = 5            the first state_id that could fail in the block
+      stop = 7             the node that may absorb the error
+      dynamic_switch = 4   dynamic check on this node
+      carry_on_data = ()   no need to carry extra data from static to dynamic
+                           checks
+*)
+
+module DynBlockData : Dyn.S
+
+type static_block_declaration = {
+  block_start : Stateid.t;
+  block_stop : Stateid.t;
+  dynamic_switch : Stateid.t;
+  carry_on_data : DynBlockData.t;
+}
+
+type document_node = {
+  indentation : int;
+  ast : Vernacexpr.vernac_expr;
+  id : Stateid.t;
+}
+
+type document_view = {
+  entry_point : document_node;
+  prev_node : document_node -> document_node option;
+}
+
+type static_block_detection =
+  document_view -> static_block_declaration option
+
+type recovery_action = {
+  base_state : Stateid.t;
+  goals_to_admit : Goal.goal list;
+  recovery_command : Vernacexpr.vernac_expr option;
+}
+
+type dynamic_block_error_recovery =
+  static_block_declaration -> [ `ValidBlock of recovery_action | `Leaks ]
+
+val register_proof_block_delimiter :
+  Vernacexpr.proof_block_name ->
+  static_block_detection ->
+  dynamic_block_error_recovery ->
+    unit
+
 (** customization ********************************************************** **)
 
 (* From the master (or worker, but beware that to install the hook
@@ -119,14 +200,15 @@ type state = {
   proof : Proof_global.state;
   shallow : bool
 }
-val state_of_id : Stateid.t -> [ `Valid of state option | `Expired ]
+val state_of_id :
+  Stateid.t -> [ `Valid of state option | `Expired | `Error of exn ]
 
 (** 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
+   [finish] is called as the last bit of this function if the system
    is running interactively (-emacs or coqtop). *)
-val interp : bool -> located_vernac_expr -> unit
+val interp : bool -> vernac_expr located -> unit
 
 (* Queries for backward compatibility *)
 val current_proof_depth : unit -> int
@@ -134,7 +216,7 @@ 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 *)
+(* Hooks to be set by other Coq components in order to break file cycles *)
 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
diff --git a/stm/stm.mllib b/stm/stm.mllib
index 92b3a869..939ee187 100644
--- a/stm/stm.mllib
+++ b/stm/stm.mllib
@@ -7,6 +7,6 @@ Vernac_classifier
 Lemmas
 CoqworkmgrApi
 AsyncTaskQueue
-Texmacspp
 Stm
+ProofBlockDelimiter
 Vio_checking
diff --git a/stm/tQueue.ml b/stm/tQueue.ml
index ee121c46..a0b08778 100644
--- a/stm/tQueue.ml
+++ b/stm/tQueue.ml
@@ -87,7 +87,7 @@ let broadcast { lock = m; cond = c } =
   Mutex.unlock m
 
 let push { queue = q; lock = m; cond = c; release } x =
-  if release then Errors.anomaly(Pp.str
+  if release then CErrors.anomaly(Pp.str
     "TQueue.push while being destroyed! Only 1 producer/destroyer allowed");
   Mutex.lock m;
   PriorityQueue.push q x;
diff --git a/stm/vcs.ml b/stm/vcs.ml
index 38c02990..d3886464 100644
--- a/stm/vcs.ml
+++ b/stm/vcs.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 
 module type S = sig
 
@@ -22,51 +22,49 @@ module type S = sig
   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
+  
+  type ('kind,'diff,'info,'property_data) t constraint 'kind = [> `Master ]
+  
+  val empty : id -> ('kind,'diff,'info,'property_data) t
+  
+  val current_branch : ('k,'e,'i,'c) t -> Branch.t
+  val branches : ('k,'e,'i,'c) t -> Branch.t list
+  
+  val get_branch : ('k,'e,'i,'c) t -> Branch.t -> 'k branch_info
+  val reset_branch : ('k,'e,'i,'c) t -> Branch.t -> id -> ('k,'e,'i,'c) 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
+    ('kind,'e,'i,'c) t -> ?root:id -> ?pos:id ->
+        Branch.t -> 'kind -> ('kind,'e,'i,'c) t
+  val delete_branch : ('k,'e,'i,'c) t -> Branch.t -> ('k,'e,'i,'c) 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
+    ('k,'diff,'i,'c) t -> id -> ours:'diff -> theirs:'diff -> ?into:Branch.t ->
+            Branch.t -> ('k,'diff,'i,'c) t
+  val commit : ('k,'diff,'i,'c) t -> id -> 'diff -> ('k,'diff,'i,'c) 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
+    ('k,'diff,'i,'c) t -> id -> ours:'diff -> theirs:'diff -> at:id ->
+            Branch.t -> ('k,'diff,'i,'c) t
+  val checkout : ('k,'e,'i,'c) t -> Branch.t -> ('k,'e,'i,'c) t
   
-  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
+  val set_info : ('k,'e,'info,'c) t -> id -> 'info -> ('k,'e,'info,'c) t
+  val get_info : ('k,'e,'info,'c) t -> id -> 'info option
 
+  (* Read only dag *)
   module Dag : Dag.S with type node = id
-  val dag : ('kind,'diff,'info) t -> ('diff,'info,id*id) Dag.t
+  val dag : ('kind,'diff,'info,'cdata) t -> ('diff,'info,'cdata) Dag.t
+
+  val create_property : ('k,'e,'i,'c) t -> id list -> 'c -> ('k,'e,'i,'c) t
+  val property_of : ('k,'e,'i,'c) t -> id -> 'c Dag.Property.t list
+  val delete_property : ('k,'e,'i,'c) t -> 'c Dag.Property.t -> ('k,'e,'i,'c) 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 
+  (* Removes all unreachable nodes and returns them *)
+  val gc : ('k,'e,'info,'c) t -> ('k,'e,'info,'c) t * Dag.NodeSet.t
+  val reachable : ('k,'e,'info,'c) t -> id -> Dag.NodeSet.t
 
 end
 
@@ -78,7 +76,6 @@ type id = OT.t
 
 module NodeSet = Dag.NodeSet
 
-
 module Branch =
 struct
   type t = string
@@ -99,10 +96,10 @@ type 'kind branch_info = {
   pos  : id;
 }
 
-type ('kind,'edge,'info) t = {
+type ('kind,'edge,'info,'property_data) t = {
   cur_branch   : Branch.t;
   heads        : 'kind branch_info BranchMap.t;
-  dag          : ('edge,'info,id*id) Dag.t;
+  dag          : ('edge,'info,'property_data) Dag.t;
 }
 
 let empty root = {
@@ -167,9 +164,9 @@ 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 create_property vcs l i = { vcs with dag = Dag.create_property vcs.dag l i }
+let property_of vcs i = Dag.property_of vcs.dag i
+let delete_property vcs c = { vcs with dag = Dag.del_property vcs.dag c }
 
 let branches vcs = BranchMap.fold (fun x _ accu -> x :: accu) vcs.heads []
 let dag vcs = vcs.dag
diff --git a/stm/vcs.mli b/stm/vcs.mli
index 8f22fee8..46b40f8a 100644
--- a/stm/vcs.mli
+++ b/stm/vcs.mli
@@ -19,10 +19,11 @@
    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:
+   The type [Vcs.t] has 4 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)
+    ['cdata] extra data hold by dag properties
 *)
 
 module type S = sig
@@ -45,46 +46,51 @@ module type S = sig
     pos  : id;
   }
   
-  type ('kind,'diff,'info) t constraint 'kind = [> `Master ]
+  type ('kind,'diff,'info,'property_data) t constraint 'kind = [> `Master ]
   
-  val empty : id -> ('kind,'diff,'info) t
+  val empty : id -> ('kind,'diff,'info,'property_data) t
   
-  val current_branch : ('k,'e,'i) t -> Branch.t
-  val branches : ('k,'e,'i) t -> Branch.t list
+  val current_branch : ('k,'e,'i,'c) t -> Branch.t
+  val branches : ('k,'e,'i,'c) 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 get_branch : ('k,'e,'i,'c) t -> Branch.t -> 'k branch_info
+  val reset_branch : ('k,'e,'i,'c) t -> Branch.t -> id -> ('k,'e,'i,'c) 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
+    ('kind,'e,'i,'c) t -> ?root:id -> ?pos:id ->
+        Branch.t -> 'kind -> ('kind,'e,'i,'c) t
+  val delete_branch : ('k,'e,'i,'c) t -> Branch.t -> ('k,'e,'i,'c) 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
+    ('k,'diff,'i,'c) t -> id -> ours:'diff -> theirs:'diff -> ?into:Branch.t ->
+            Branch.t -> ('k,'diff,'i,'c) t
+  val commit : ('k,'diff,'i,'c) t -> id -> 'diff -> ('k,'diff,'i,'c) 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
+    ('k,'diff,'i,'c) t -> id -> ours:'diff -> theirs:'diff -> at:id ->
+            Branch.t -> ('k,'diff,'i,'c) t
+  val checkout : ('k,'e,'i,'c) t -> Branch.t -> ('k,'e,'i,'c) t
   
-  val set_info : ('k,'e,'info) t -> id -> 'info -> ('k,'e,'info) t
-  val get_info : ('k,'e,'info) t -> id -> 'info option
+  val set_info : ('k,'e,'info,'c) t -> id -> 'info -> ('k,'e,'info,'c) t
+  val get_info : ('k,'e,'info,'c) t -> id -> 'info option
 
-  module NodeSet : Set.S with type elt = id
+  (* Read only dag *)
+  module Dag : Dag.S with type node = id
+  val dag : ('kind,'diff,'info,'cdata) t -> ('diff,'info,'cdata) Dag.t
   
-  (* Removes all unreachable nodes and returns them *)
-  val gc : ('k,'e,'info) t -> ('k,'e,'info) t * NodeSet.t
+  (* Properties are not a concept typical of a VCS, but a useful metadata
+   * of a DAG (or graph). *)
+  val create_property : ('k,'e,'i,'c) t -> id list -> 'c -> ('k,'e,'i,'c) t
+  val property_of : ('k,'e,'i,'c) t -> id -> 'c Dag.Property.t list
+  val delete_property : ('k,'e,'i,'c) t -> 'c Dag.Property.t -> ('k,'e,'i,'c) t 
 
-  val reachable : ('k,'e,'info) t -> id -> NodeSet.t
+  (* Removes all unreachable nodes and returns them *)
+  val gc : ('k,'e,'info,'c) t -> ('k,'e,'info,'c) t * Dag.NodeSet.t
+  val reachable : ('k,'e,'info,'c) t -> id -> Dag.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
+module Make(OT : Map.OrderedType) : S
+with type id = OT.t
+and type Dag.node = OT.t
+and type Dag.NodeSet.t = Set.Make(OT).t
+and type Dag.NodeSet.elt = OT.t
+
diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml
index edb54ece..dc5be08a 100644
--- a/stm/vernac_classifier.ml
+++ b/stm/vernac_classifier.ml
@@ -7,11 +7,18 @@
 (************************************************************************)
 
 open Vernacexpr
-open Errors
+open CErrors
 open Pp
 
+let default_proof_mode () = Proof_global.get_default_proof_mode_name ()
+
 let string_of_in_script b = if b then " (inside script)" else ""
 
+let string_of_parallel = function
+  | `Yes (solve,abs) ->
+       "par" ^ if solve then "solve" else "" ^ if abs then "abs" else ""
+  | `No -> ""
+
 let string_of_vernac_type = function
   | VtUnknown -> "Unknown"
   | VtStartProof _ -> "StartProof"
@@ -19,8 +26,9 @@ let string_of_vernac_type = function
   | VtQed VtKeep -> "Qed(keep)"
   | VtQed VtKeepAsAxiom -> "Qed(admitted)"
   | VtQed VtDrop -> "Qed(drop)"
-  | VtProofStep false -> "ProofStep"
-  | VtProofStep true -> "ProofStep (parallel)"
+  | VtProofStep { parallel; proof_block_detection } ->
+      "ProofStep " ^ string_of_parallel parallel ^
+        Option.default "" proof_block_detection
   | VtProofMode s -> "ProofMode " ^ s
   | VtQuery (b,(id,route)) ->
       "Query " ^ string_of_in_script b ^ " report " ^ Stateid.to_string id ^
@@ -60,7 +68,7 @@ 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
+  let static_classifier e = match e with
     (* PG compatibility *)
     | VernacUnsetOption (["Silent"]|["Undo"]|["Printing";"Depth"])
     | VernacSetOption   ((["Silent"]|["Undo"]|["Printing";"Depth"]),_)
@@ -86,12 +94,14 @@ let rec classify_vernac e =
 	make_polymorphic (classify_vernac e)
       else classify_vernac e
     | VernacTimeout (_,e) -> classify_vernac e
-    | VernacTime e | VernacRedirect (_, e) -> classify_vernac_list e
+    | VernacTime (_,e) | VernacRedirect (_, (_,e)) -> classify_vernac 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
+        | VtQed _, _ ->
+            VtProofStep { parallel = `No; proof_block_detection = None },
+            VtNow
         | (VtStartProof _ | VtUnknown), _ -> VtUnknown, VtNow)
     (* Qed *)
     | VernacAbort _ -> VtQed VtDrop, VtLater
@@ -102,42 +112,47 @@ let rec classify_vernac e =
     | VernacCheckMayEval _ ->
         VtQuery (true,(Stateid.dummy,Feedback.default_route)), VtLater
     (* ProofStep *)
-    | VernacSolve (SelectAllParallel,_,_,_) -> VtProofStep true, VtLater
     | VernacProof _ 
-    | VernacBullet _ 
     | VernacFocus _ | VernacUnfocus
-    | VernacSubproof _ | VernacEndSubproof
-    | VernacSolve _ 
+    | VernacSubproof _
     | VernacCheckGuard
     | VernacUnfocused
-    | VernacSolveExistential _ -> VtProofStep false, VtLater
+    | VernacSolveExistential _ ->
+        VtProofStep { parallel = `No; proof_block_detection = None }, VtLater
+    | VernacBullet _ ->
+        VtProofStep { parallel = `No; proof_block_detection = Some "bullet" },
+        VtLater
+    | VernacEndSubproof -> 
+        VtProofStep { parallel = `No;
+                      proof_block_detection = Some "curly" },
+        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
+        VtStartProof(default_proof_mode (),Doesn'tGuaranteeOpacity,[i]), VtLater
     | VernacDefinition (_,((_,i),_),ProveBody _) ->
-        VtStartProof("Classic",GuaranteesOpacity,[i]), VtLater
+        VtStartProof(default_proof_mode (),GuaranteesOpacity,[i]), VtLater
     | VernacStartTheoremProof (_,l,_) ->
         let ids = 
           CList.map_filter (function (Some ((_,i),pl), _) -> Some i | _ -> None) l in
-        VtStartProof ("Classic",GuaranteesOpacity,ids), VtLater
-    | VernacGoal _ -> VtStartProof ("Classic",GuaranteesOpacity,[]), VtLater
+        VtStartProof (default_proof_mode (),GuaranteesOpacity,ids), VtLater
+    | VernacGoal _ -> VtStartProof (default_proof_mode (),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
+        then VtStartProof (default_proof_mode (),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
+        then VtStartProof (default_proof_mode (),GuaranteesOpacity,ids), VtLater
         else VtSideff ids, VtLater
     (* Sideff: apply to all open branches. usually run on master only *)
     | VernacAssumption (_,_,l) ->
@@ -166,7 +181,7 @@ let rec classify_vernac e =
     | VernacReserve _
     | VernacGeneralizable _
     | VernacSetOpacity _ | VernacSetStrategy _
-    | VernacUnsetOption _ | VernacSetOption _
+    | VernacUnsetOption _ | VernacSetOption _ | VernacSetAppendOption _
     | VernacAddOption _ | VernacRemoveOption _
     | VernacMemOption _ | VernacPrintOption _
     | VernacGlobalCheck _
@@ -175,11 +190,6 @@ let rec classify_vernac e =
     | VernacRegister _
     | VernacNameSectionHypSet _
     | VernacComments _ -> VtSideff [], VtLater
-    | VernacDeclareTacticDefinition (_,l) ->
-        let open Libnames in
-        VtSideff (List.map (function
-          | (Ident (_,r),_,_) -> r
-          | (Qualid (_,q),_,_) -> snd(repr_qualid q)) l), VtLater
     (* Who knows *)
     | VernacLoad _ -> VtSideff [], VtNow
     (* (Local) Notations have to disappear *)
@@ -195,7 +205,6 @@ let rec classify_vernac e =
     | VernacInfix _ | VernacNotation _ | VernacNotationAddFormat _
     | VernacSyntaxExtension _ 
     | VernacSyntacticDefinition _
-    | VernacTacticNotation _
     | VernacRequire _ | VernacImport _ | VernacInclude _
     | VernacDeclareMLModule _
     | VernacContext _ (* TASSI: unsure *)
@@ -208,7 +217,6 @@ let rec classify_vernac e =
     | VernacResetName _ | VernacResetInitial
     | VernacBacktrack _ | VernacBackTo _ | VernacRestart -> !undo_classifier e
     (* What are these? *)
-    | VernacNop
     | VernacToplevelControl _
     | VernacRestoreState _
     | VernacWriteState _ -> VtUnknown, VtNow
@@ -217,13 +225,6 @@ let rec classify_vernac e =
     | 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
@@ -233,4 +234,4 @@ let rec classify_vernac e =
 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
+let classify_as_proofstep = VtProofStep { parallel = `No; proof_block_detection = None}, VtLater
diff --git a/stm/vio_checking.ml b/stm/vio_checking.ml
index d4dcf72c..a6237daa 100644
--- a/stm/vio_checking.ml
+++ b/stm/vio_checking.ml
@@ -24,7 +24,7 @@ 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";
+  if j < 1 then CErrors.error "The number of workers must be bigger than 0";
   let jobs = ref [] in
   List.iter (fun f ->
     let f =
@@ -98,7 +98,7 @@ let schedule_vio_checking j fs =
   exit !rc
 
 let schedule_vio_compilation j fs =
-  if j < 1 then Errors.error "The number of workers must be bigger than 0";
+  if j < 1 then CErrors.error "The number of workers must be bigger than 0";
   let jobs = ref [] in
   List.iter (fun f ->
     let f =
diff --git a/stm/workerPool.ml b/stm/workerPool.ml
index b94fae54..9623765d 100644
--- a/stm/workerPool.ml
+++ b/stm/workerPool.ml
@@ -52,7 +52,7 @@ let master_handshake worker_id ic oc =
       Printf.eprintf "Handshake with %s failed: protocol mismatch\n" worker_id;
       exit 1;
     end
-  with e when Errors.noncritical e ->
+  with e when CErrors.noncritical e ->
     Printf.eprintf "Handshake with %s failed: %s\n"
       worker_id (Printexc.to_string e);
     exit 1
@@ -65,7 +65,7 @@ let worker_handshake slave_ic slave_oc =
       exit 1;
     end;
     Marshal.to_channel slave_oc v []; flush slave_oc;
-  with e when Errors.noncritical e ->
+  with e when CErrors.noncritical e ->
     prerr_endline ("Handshake failed: " ^ Printexc.to_string e);
     exit 1
 
diff --git a/tactics/auto.ml b/tactics/auto.ml
index 2d92387c..bc644857 100644
--- a/tactics/auto.ml
+++ b/tactics/auto.ml
@@ -10,7 +10,7 @@
 *)
 open Pp
 open Util
-open Errors
+open CErrors
 open Names
 open Vars
 open Termops
@@ -35,6 +35,10 @@ open Hints
 
 let priority l = List.filter (fun (_, hint) -> Int.equal hint.pri 0) l
 
+let compute_secvars gl =
+  let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in
+  secvars_of_hyps hyps
+
 (* tell auto not to reuse already instantiated metas in unification (for
    compatibility, since otherwise, apply succeeds oftener) *)
 
@@ -67,16 +71,13 @@ let auto_unif_flags_of st1 st2 useeager =
 let auto_unif_flags =
   auto_unif_flags_of full_transparent_state empty_transparent_state false
 
-let auto_flags_of_state st =
-  auto_unif_flags_of full_transparent_state st false
-
 (* Try unification with the precompiled clause, then use registered Apply *)
 
 let connect_hint_clenv poly (c, _, ctx) clenv gl =
   (** [clenv] has been generated by a hint-making function, so the only relevant
       data in its evarmap is the set of metas. The [evar_reset_evd] function
       below just replaces the metas of sigma by those coming from the clenv. *)
-  let sigma = Proofview.Goal.sigma gl in
+  let sigma = Tacmach.New.project gl in
   let evd = Evd.evars_reset_evd ~with_conv_pbs:true ~with_univs:false sigma clenv.evd in
   (** Still, we need to update the universes *)
   let clenv, c =
@@ -85,22 +86,25 @@ let connect_hint_clenv poly (c, _, ctx) clenv gl =
       let (subst, ctx) = Universes.fresh_universe_context_set_instance ctx in
       let map c = Vars.subst_univs_level_constr subst c in
       let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in
-      let clenv = { clenv with evd = evd ; env = Proofview.Goal.env gl } in
-      (** FIXME: We're being inefficient here because we substitute the whole
-          evar map instead of just its metas, which are the only ones
-          mentioning the old universes. *)
-      Clenv.map_clenv map clenv, map c
+      (** Only metas are mentioning the old universes. *)
+      let clenv = {
+        templval = Evd.map_fl map clenv.templval;
+        templtyp = Evd.map_fl map clenv.templtyp;
+        evd = Evd.map_metas map evd;
+        env = Proofview.Goal.env gl;
+      } in
+      clenv, map c
     else
       let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in
       { clenv with evd = evd ; env = Proofview.Goal.env gl }, c
   in clenv, c
-		     
+
 let unify_resolve poly flags ((c : raw_hint), clenv) =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let clenv, c = connect_hint_clenv poly c clenv gl in
   let clenv = Tacmach.New.of_old (fun gl -> clenv_unique_resolver ~flags clenv gl) gl in
   Clenvtac.clenv_refine false clenv
-  end
+  end }
 
 let unify_resolve_nodelta poly h = unify_resolve poly auto_unif_flags h
 
@@ -109,20 +113,12 @@ let unify_resolve_gen poly = function
   | Some flags -> unify_resolve poly flags
 
 let exact poly (c,clenv) =
-  let (c, _, _) = c in
-  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
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let clenv', c = connect_hint_clenv poly c clenv gl in
+    Tacticals.New.tclTHEN
+    (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd))
+    (exact_check c)
+  end }
 
 (* Util *)
 
@@ -138,8 +134,6 @@ si après Intros la conclusion matche le pattern.
 
 (* conclPattern doit échouer avec error car il est rattraper par tclFIRST *)
 
-let (forward_interp_tactic, extern_interp) = Hook.make ()
-
 let conclPattern concl pat tac =
   let constr_bindings env sigma =
     match pat with
@@ -150,11 +144,23 @@ let conclPattern concl pat tac =
 	with Constr_matching.PatternMatchingFailure ->
           Tacticals.New.tclZEROMSG (str "conclPattern")
   in
-   Proofview.Goal.enter (fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
      let env = Proofview.Goal.env gl in
-     let sigma = Proofview.Goal.sigma gl in
+     let sigma = Tacmach.New.project gl in
        constr_bindings env sigma >>= fun constr_bindings ->
-     Hook.get forward_interp_tactic constr_bindings tac)
+     let open Genarg in
+     let open Geninterp in
+     let inj c = match val_tag (topwit Constrarg.wit_constr) with
+     | Val.Base tag -> Val.Dyn (tag, c)
+     | _ -> assert false
+     in
+     let fold id c accu = Id.Map.add id (inj c) accu in
+     let lfun = Id.Map.fold fold constr_bindings Id.Map.empty in
+     let ist = { lfun; extra = TacStore.empty } in
+     match tac with
+     | GenArg (Glbwit wit, tac) ->
+      Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ())
+  end }
 
 (***********************************************************)
 (** A debugging / verbosity framework for trivial and auto *)
@@ -217,11 +223,11 @@ let tclLOG (dbg,depth,trace) pp tac =
       Proofview.V82.tactic begin fun gl ->
 	try
 	  let out = Proofview.V82.of_tactic tac gl in
-	  msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)");
+	  Feedback.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*)");
+          let reraise = CErrors.push reraise in
+	  Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)");
 	  iraise reraise
       end
     | Info ->
@@ -232,7 +238,7 @@ let tclLOG (dbg,depth,trace) pp tac =
 	  trace := (depth, Some pp) :: !trace;
 	  out
 	with reraise ->
-          let reraise = Errors.push reraise in
+          let reraise = CErrors.push reraise in
 	  trace := (depth, None) :: !trace;
 	  iraise reraise
       end
@@ -258,31 +264,25 @@ let pr_info_atom (d,pp) =
 
 let pr_info_trace = function
   | (Info,_,{contents=(d,Some pp)::l}) ->
-      prlist_with_sep fnl pr_info_atom (cleanup_info_trace d [(d,pp)] l)
-  | _ -> mt ()
+      Feedback.msg_info (prlist_with_sep fnl pr_info_atom (cleanup_info_trace d [(d,pp)] l))
+  | _ -> ()
 
 let pr_info_nop = function
-  | (Info,_,_) -> str "idtac."
-  | _ -> mt ()
+  | (Info,_,_) -> Feedback.msg_info (str "idtac.")
+  | _ -> ()
 
 let pr_dbg_header = function
-  | (Off,_,_) -> mt ()
-  | (Debug,0,_) -> str "(* debug trivial : *)"
-  | (Debug,_,_) -> str "(* debug auto : *)"
-  | (Info,0,_) -> str "(* info trivial : *)"
-  | (Info,_,_) -> str "(* info auto : *)"
+  | (Off,_,_) -> ()
+  | (Debug,0,_) -> Feedback.msg_debug (str "(* debug trivial: *)")
+  | (Debug,_,_) -> Feedback.msg_debug (str "(* debug auto: *)")
+  | (Info,0,_) -> Feedback.msg_info (str "(* info trivial: *)")
+  | (Info,_,_) -> Feedback.msg_info (str "(* info auto: *)")
 
 let tclTRY_dbg d tac =
-  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
+  let tac = delay (fun () -> pr_dbg_header d; tac) >>=
+              fun () -> pr_info_trace d; Proofview.tclUNIT () in
+  let after = delay (fun () -> pr_info_nop d; Proofview.tclUNIT ()) in
   Tacticals.New.tclORELSE0 tac after
 
 (**************************************************************************)
@@ -293,21 +293,19 @@ 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_of st st false
 
 let auto_flags_of_state st =
   auto_unif_flags_of full_transparent_state st false
 
-let hintmap_of hdc concl =
+let hintmap_of secvars hdc concl =
   match hdc with
-  | None -> Hint_db.map_none
+  | None -> Hint_db.map_none ~secvars
   | Some hdc ->
-      if occur_existential concl then Hint_db.map_existential hdc concl
-      else Hint_db.map_auto hdc concl
+     if occur_existential concl then
+       Hint_db.map_existential ~secvars hdc concl
+     else Hint_db.map_auto ~secvars hdc concl
 
 let exists_evaluable_reference env = function
   | EvalConstRef _ -> true
@@ -319,35 +317,36 @@ let dbg_assumption dbg = tclLOG dbg (fun () -> str "assumption") assumption
 let rec trivial_fail_db dbg mod_delta db_list local_db =
   let intro_tac =
     Tacticals.New.tclTHEN (dbg_intro dbg)
-      ( Proofview.Goal.enter begin fun gl ->
-          let sigma = Proofview.Goal.sigma gl in
+      ( Proofview.Goal.enter { enter = begin fun gl ->
+          let sigma = Tacmach.New.project 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 hyp = Context.Named.Declaration.map_constr nf decl in
 	  let hintl = make_resolve_hyp env sigma hyp
 	  in trivial_fail_db dbg mod_delta db_list
 	       (Hint_db.add_list env sigma hintl local_db)
-      end)
+      end })
   in
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
     let concl = Tacmach.New.pf_nf_concl gl in
+    let secvars = compute_secvars 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
+             (trivial_resolve dbg mod_delta db_list local_db secvars concl)))
+  end }
 
-and my_find_search_nodelta db_list local_db hdc concl =
+and my_find_search_nodelta db_list local_db secvars hdc concl =
   List.map (fun hint -> (None,hint))
-    (List.map_append (hintmap_of hdc concl) (local_db::db_list))
+    (List.map_append (hintmap_of secvars 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 f = hintmap_of hdc concl in
+and my_find_search_delta db_list local_db secvars hdc concl =
+  let f = hintmap_of secvars hdc concl in
     if occur_existential concl then
       List.map_append
 	(fun db ->
@@ -367,16 +366,16 @@ and my_find_search_delta db_list local_db hdc concl =
 	  let (ids, csts as st) = Hint_db.transparent_state db in
 	  let flags, l =
 	    let l =
-	      match hdc with None -> Hint_db.map_none db
+	      match hdc with None -> Hint_db.map_none ~secvars db
 	      | Some hdc ->
 		  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
+		  then Hint_db.map_auto ~secvars hdc concl db
+		  else Hint_db.map_existential ~secvars 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;poly=poly})) =
+and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db=dbname})) =
   let tactic = function
     | Res_pf (c,cl) -> unify_resolve_gen poly flags (c,cl)
     | ERes_pf _ -> Proofview.V82.tactic (fun gl -> error "eres_pf")
@@ -390,14 +389,21 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly}))
     | Unfold_nth c ->
       Proofview.V82.tactic (fun gl ->
        if exists_evaluable_reference (pf_env gl) c then
-	 tclPROGRESS (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl) gl
+	 tclPROGRESS (Proofview.V82.of_tactic (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl)) gl
        else tclFAIL 0 (str"Unbound reference") gl)
     | Extern tacast -> 
       conclPattern concl p tacast
   in
-  tclLOG dbg (fun () -> pr_hint t) (run_hint t tactic)
+  let pr_hint () =
+    let origin = match dbname with
+    | None -> mt ()
+    | Some n -> str " (in " ++ str n ++ str ")"
+    in
+    pr_hint t ++ origin
+  in
+  tclLOG dbg pr_hint (run_hint t tactic)
 
-and trivial_resolve dbg mod_delta db_list local_db cl =
+and trivial_resolve dbg mod_delta db_list local_db secvars cl =
   try
     let head =
       try let hdconstr = decompose_app_bound cl in
@@ -406,33 +412,33 @@ and trivial_resolve dbg mod_delta db_list local_db cl =
     in
       List.map (tac_of_hint dbg db_list local_db cl)
 	(priority
-	    (my_find_search mod_delta db_list local_db head cl))
+	    (my_find_search mod_delta db_list local_db secvars head cl))
   with Not_found -> []
 
 (** The use of the "core" database can be de-activated by passing
     "nocore" amongst the databases. *)
 
 let trivial ?(debug=Off) lems dbnames =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let env = Proofview.Goal.env gl in
-  let sigma = Proofview.Goal.sigma gl in
+  let sigma = Tacmach.New.project 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 hints)
-  end
+  end }
 
 let full_trivial ?(debug=Off) lems =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let env = Proofview.Goal.env gl in
-  let sigma = Proofview.Goal.sigma gl in
+  let sigma = Tacmach.New.project 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 hints)
-  end
+  end }
 
 let gen_trivial ?(debug=Off) lems = function
   | None -> full_trivial ~debug lems
@@ -444,7 +450,7 @@ let h_trivial ?(debug=Off) lems l = gen_trivial ~debug lems l
 (*                       The classical Auto tactic                        *)
 (**************************************************************************)
 
-let possible_resolve dbg mod_delta db_list local_db cl =
+let possible_resolve dbg mod_delta db_list local_db secvars cl =
   try
     let head =
       try let hdconstr = decompose_app_bound cl in
@@ -452,12 +458,12 @@ let possible_resolve dbg mod_delta db_list local_db cl =
       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)
+	(my_find_search mod_delta db_list local_db secvars head cl)
   with Not_found -> []
 
 let extend_local_db decl db gl =
   let env = Tacmach.New.pf_env gl in
-  let sigma = Proofview.Goal.sigma gl in
+  let sigma = Tacmach.New.project gl in
   Hint_db.add_list env sigma (make_resolve_hyp env sigma decl) db
 
 (* Introduce an hypothesis, then call the continuation tactic [kont]
@@ -465,10 +471,10 @@ let extend_local_db decl db gl =
 
 let intro_register dbg kont db =
   Tacticals.New.tclTHEN (dbg_intro dbg)
-    (Proofview.Goal.enter begin fun gl ->
+    (Proofview.Goal.enter { 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)
+    end })
 
 (* n is the max depth of search *)
 (* local_db contains the local Hypotheses *)
@@ -481,14 +487,15 @@ let search d n mod_delta db_list local_db =
       if Int.equal n 0 then Tacticals.New.tclZEROMSG (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 ->
+	     ( Proofview.Goal.enter { enter = begin fun gl ->
                let concl = Tacmach.New.pf_nf_concl gl in
+               let secvars = compute_secvars 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))
+		    (possible_resolve d mod_delta db_list local_db secvars concl))
+             end }))
     end []
   in
   search d n local_db
@@ -496,15 +503,15 @@ let search d n mod_delta db_list local_db =
 let default_search_depth = ref 5
 
 let delta_auto debug mod_delta n lems dbnames =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let env = Proofview.Goal.env gl in
-  let sigma = Proofview.Goal.sigma gl in
+  let sigma = Tacmach.New.project 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 hints)
-  end
+  end }
 
 let delta_auto = 
   if Flags.profile then
@@ -519,15 +526,15 @@ 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 =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let env = Proofview.Goal.env gl in
-  let sigma = Proofview.Goal.sigma gl in
+  let sigma = Tacmach.New.project 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 hints)
-  end
+  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
diff --git a/tactics/auto.mli b/tactics/auto.mli
index 2e5647f8..3befaaad 100644
--- a/tactics/auto.mli
+++ b/tactics/auto.mli
@@ -6,31 +6,25 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(** This files implements auto and related automation tactics *)
+
 open Names
 open Term
 open Clenv
 open Pattern
-open Evd
 open Decl_kinds
 open Hints
 
-val extern_interp :
-  (patvar_map -> Tacexpr.glob_tactic_expr -> unit Proofview.tactic) Hook.t
-
-(** Auto and related automation tactics *)
-
-val priority : ('a * full_hint) list -> ('a * full_hint) list
+val compute_secvars : ('a,'b) Proofview.Goal.t -> Id.Pred.t
 
 val default_search_depth : int ref
 
 val auto_flags_of_state : transparent_state -> Unification.unify_flags
 
 val connect_hint_clenv : polymorphic -> raw_hint -> clausenv ->
-			 [ `NF ] Proofview.Goal.t -> clausenv * constr
-						
-(** Try unification with the precompiled clause, then use registered Apply *)
-val unify_resolve_nodelta : polymorphic -> (raw_hint * clausenv) -> unit Proofview.tactic
+  ('a, 'r) Proofview.Goal.t -> clausenv * constr
 
+(** Try unification with the precompiled clause, then use registered Apply *)
 val unify_resolve : polymorphic -> Unification.unify_flags -> (raw_hint * clausenv) -> unit Proofview.tactic
 
 (** [ConclPattern concl pat tacast]:
@@ -38,7 +32,7 @@ val unify_resolve : polymorphic -> Unification.unify_flags -> (raw_hint * clause
    [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 -> unit Proofview.tactic
+val conclPattern : constr -> constr_pattern option -> Genarg.glob_generic_argument -> unit Proofview.tactic
 
 (** The Auto tactic *)
 
@@ -46,44 +40,42 @@ val conclPattern : constr -> constr_pattern option -> Tacexpr.glob_tactic_expr -
     "nocore" amongst the databases. *)
 
 val auto : ?debug:Tacexpr.debug ->
-  int -> open_constr list -> hint_db_name list -> unit Proofview.tactic
+  int -> Tacexpr.delayed_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 -> unit Proofview.tactic
+  int -> Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic
 
 (** auto with default search depth and with the hint database "core" *)
 val default_auto : unit Proofview.tactic
 
-(** auto with all hint databases except the "v62" compatibility database *)
+(** auto with all hint databases *)
 val full_auto : ?debug:Tacexpr.debug ->
-  int -> open_constr list -> unit Proofview.tactic
+  int -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic
 
-(** auto with all hint databases except the "v62" compatibility database
-   and doing delta *)
+(** auto with all hint databases and doing delta *)
 val new_full_auto : ?debug:Tacexpr.debug ->
-  int -> open_constr list -> unit Proofview.tactic
+  int -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic
 
-(** auto with default search depth and with all hint databases
-   except the "v62" compatibility database *)
+(** auto with default search depth and with all hint databases *)
 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 -> unit Proofview.tactic
+  int option -> Tacexpr.delayed_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 -> unit Proofview.tactic
+  int option -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic
 
 (** Trivial *)
 
 val trivial : ?debug:Tacexpr.debug ->
-  open_constr list -> hint_db_name list -> unit Proofview.tactic
+  Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic
 val gen_trivial : ?debug:Tacexpr.debug ->
-  open_constr list -> hint_db_name list option -> unit Proofview.tactic
+  Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic
 val full_trivial : ?debug:Tacexpr.debug ->
-  open_constr list -> unit Proofview.tactic
+  Tacexpr.delayed_open_constr list -> unit Proofview.tactic
 val h_trivial : ?debug:Tacexpr.debug ->
-  open_constr list -> hint_db_name list option -> unit Proofview.tactic
+  Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic
diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml
index 49e5c620..47500564 100644
--- a/tactics/autorewrite.ml
+++ b/tactics/autorewrite.ml
@@ -13,11 +13,11 @@ open Tacticals
 open Tactics
 open Term
 open Termops
-open Errors
+open CErrors
 open Util
-open Tacexpr
 open Mod_subst
 open Locus
+open Proofview.Notations
 
 (* Rewriting rules *)
 type rew_rule = { rew_lemma: constr;
@@ -25,13 +25,13 @@ type rew_rule = { rew_lemma: constr;
 		  rew_pat: constr;
 		  rew_ctx: Univ.universe_context_set;
 		  rew_l2r: bool;
-		  rew_tac: glob_tactic_expr option }
+		  rew_tac: Genarg.glob_generic_argument 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' = Option.smartmap (Tacsubst.subst_tactic subst) hint.rew_tac in
+  let t' = Option.smartmap (Genintern.generic_substitute 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';
@@ -83,24 +83,31 @@ let print_rewrite_hintdb bas =
 	     str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++
 	       Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++
 	       Option.cata (fun tac -> str " then use tactic " ++
-	       Pptactic.pr_glob_tactic (Global.env()) tac) (mt ()) h.rew_tac)
+	       Pptactic.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac)
 	   (find_rewrites bas))
 
-type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * raw_tactic_expr option
+type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument 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 try_rewrite dir ctx c tc = Proofview.Goal.nf_enter (fun gl ->
+  let try_rewrite dir ctx c tc =
+  Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
     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 = Sigma.to_evar_map sigma 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 tac = general_rewrite_maybe_in dir c' tc in
+    Sigma.Unsafe.of_pair (tac, sigma)
+  end } in
   let lrul = List.map (fun h -> 
-  let tac = match h.rew_tac with None -> Proofview.tclUNIT () | Some t -> Tacinterp.eval_tactic t in
+  let tac = match h.rew_tac with
+  | None -> Proofview.tclUNIT ()
+  | Some (Genarg.GenArg (Genarg.Glbwit wit, tac)) ->
+    let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in
+    Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ())
+  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
@@ -120,7 +127,7 @@ let autorewrite ?(conds=Naive) tac_main lbas =
       (Proofview.tclUNIT()) lbas))
 
 let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
  (* let's check at once if id exists (to raise the appropriate error) *)
  let _ = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) idl in
  let general_rewrite_in id =
@@ -129,7 +136,7 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas =
    fun dir cstr tac gl ->
     let last_hyp_id =
      match Tacmach.pf_hyps gl with
-        (last_hyp_id,_,_)::_ -> last_hyp_id
+        d :: _ -> Context.Named.Declaration.get_id d
       | _ -> (* even the hypothesis id is missing *)
         raise (Logic.RefinerError (Logic.NoSuchHyp !id))
     in
@@ -138,12 +145,13 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas =
     match gls with
        g::_ ->
         (match Environ.named_context_of_val (Goal.V82.hyps gl'.Evd.sigma g) with
-            (lastid,_,_)::_ ->
+            d ::_ ->
+              let lastid = Context.Named.Declaration.get_id d in
               if not (Id.equal last_hyp_id lastid) then
                begin
                 let gl'' =
                   if !to_be_cleared then
-                   tclTHEN (fun _ -> gl') (tclTRY (clear [!id])) gl
+                   tclTHEN (fun _ -> gl') (tclTRY (Proofview.V82.of_tactic (clear [!id]))) gl
                   else gl' in
                 id := lastid ;
                 to_be_cleared := true ;
@@ -163,7 +171,7 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas =
     (List.fold_left (fun tac bas ->
        Tacticals.New.tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) (Proofview.tclUNIT()) lbas)))
    idl
- end
+ end }
 
 let autorewrite_in ?(conds=Naive) id = autorewrite_multi_in ~conds [id]
 
@@ -188,12 +196,13 @@ let gen_auto_multi_rewrite conds tac_main lbas cl =
 	   | None ->
 		 (* try to rewrite in all hypothesis
 		    (except maybe the rewritten one) *)
-               Proofview.Goal.nf_enter begin fun gl ->
+               Proofview.Goal.nf_enter { enter = begin fun gl ->
                  let ids = Tacmach.New.pf_ids_of_hyps gl in
 		 try_do_hyps (fun id -> id)  ids
-               end)
+               end })
 
-let auto_multi_rewrite ?(conds=Naive) = gen_auto_multi_rewrite conds (Proofview.tclUNIT())
+let auto_multi_rewrite ?(conds=Naive) lems cl =
+  Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds (Proofview.tclUNIT()) lems cl)
 
 let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl =
   let onconcl = match cl.Locus.concl_occs with NoOccurrences -> false | _ -> true in
@@ -202,7 +211,7 @@ let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl =
 	(* 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
+	Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds tac_main lbas cl)
     | _ ->
         Tacticals.New.tclZEROMSG (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.")
 
@@ -294,6 +303,8 @@ let add_rew_rules base lrul =
   let counter = ref 0 in
   let env = Global.env () in
   let sigma = Evd.from_env env in
+  let ist = { Genintern.ltacvars = Id.Set.empty; genv = Global.env () } in
+  let intern tac = snd (Genintern.generic_intern ist tac) in
   let lrul =
     List.fold_left
       (fun dn (loc,(c,ctx),b,t) ->
@@ -302,7 +313,7 @@ let add_rew_rules base lrul =
 	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_ctx = ctx; rew_l2r = b;
-		    rew_tac = Option.map Tacintern.glob_tactic t}
+		    rew_tac = Option.map intern 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 6196b04e..07065717 100644
--- a/tactics/autorewrite.mli
+++ b/tactics/autorewrite.mli
@@ -6,12 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(** This files implements the autorewrite tactic. *)
+
 open Term
 open Tacexpr
 open Equality
 
 (** Rewriting rules before tactic interpretation *)
-type raw_rew_rule = Loc.t * Term.constr Univ.in_universe_context_set * bool * Tacexpr.raw_tactic_expr option
+type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option
 
 (** To add rewriting rules to a base *)
 val add_rew_rules : string -> raw_rew_rule list -> unit
@@ -29,7 +31,7 @@ type rew_rule = { rew_lemma: constr;
 		  rew_pat: constr;
 		  rew_ctx: Univ.universe_context_set;
 		  rew_l2r: bool;
-		  rew_tac: glob_tactic_expr option }
+		  rew_tac: Genarg.glob_generic_argument option }
 
 val find_rewrites : string -> rew_rule list
 
diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml
index 5b3231de..b416bc65 100644
--- a/tactics/class_tactics.ml
+++ b/tactics/class_tactics.ml
@@ -6,8 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(* TODO:
+  - Find an interface allowing eauto to backtrack when shelved goals remain,
+   e.g. to force instantiations.
+ *)
+
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Term
@@ -28,23 +33,66 @@ open Hints
 
 (** Hint database named "typeclass_instances", now created directly in Auto *)
 
-let typeclasses_debug = ref false
+(** Options handling *)
+
+let typeclasses_debug = ref 0
 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
 
+(** When this flag is enabled, the resolution of type classes tries to avoid
+    useless introductions. This is no longer useful since we have eta, but is
+    here for compatibility purposes. Another compatibility issues is that the
+    cost (in terms of search depth) can differ. *)
+let typeclasses_limit_intros = ref true
+let set_typeclasses_limit_intros d = (:=) typeclasses_limit_intros d
+let get_typeclasses_limit_intros () = !typeclasses_limit_intros
+
 let typeclasses_dependency_order = ref false
 let set_typeclasses_dependency_order d = (:=) typeclasses_dependency_order d
 let get_typeclasses_dependency_order () = !typeclasses_dependency_order
 
+let typeclasses_iterative_deepening = ref false
+let set_typeclasses_iterative_deepening d = (:=) typeclasses_iterative_deepening d
+let get_typeclasses_iterative_deepening () = !typeclasses_iterative_deepening
+
+(** [typeclasses_filtered_unif] governs the unification algorithm used by type
+    classes. If enabled, a new algorithm based on pattern filtering and refine
+    will be used. When disabled, the previous algorithm based on apply will be
+    used. *)
+let typeclasses_filtered_unification = ref false
+let set_typeclasses_filtered_unification d =
+  (:=) typeclasses_filtered_unification d
+let get_typeclasses_filtered_unification () =
+  !typeclasses_filtered_unification
+
+(** [typeclasses_legacy_resolution] falls back to the 8.5 resolution algorithm,
+    instead of the 8.6 one which uses the native backtracking facilities of the
+    proof engine. *)
+let typeclasses_legacy_resolution = ref false
+let set_typeclasses_legacy_resolution d = (:=) typeclasses_legacy_resolution d
+let get_typeclasses_legacy_resolution () = !typeclasses_legacy_resolution
+
+let set_typeclasses_debug d = (:=) typeclasses_debug (if d then 1 else 0)
+let get_typeclasses_debug () = if !typeclasses_debug > 0 then true else false
+
+let set_typeclasses_verbose =
+  function None -> typeclasses_debug := 0
+         | Some n -> (:=) typeclasses_debug n
+let get_typeclasses_verbose () =
+  if !typeclasses_debug = 0 then None else Some !typeclasses_debug
+
+let set_typeclasses_depth d = (:=) typeclasses_depth d
+let get_typeclasses_depth () = !typeclasses_depth
+
 open Goptions
 
 let _ =
   declare_bool_option
     { optsync  = true;
-      optdepr  = false;
+      optdepr  = true;
       optname  = "do typeclass search modulo eta conversion";
       optkey   = ["Typeclasses";"Modulo";"Eta"];
       optread  = get_typeclasses_modulo_eta;
@@ -54,47 +102,97 @@ let _ =
   declare_bool_option
     { optsync  = true;
       optdepr  = false;
+      optname  = "do typeclass search avoiding eta-expansions " ^
+                   " in proof terms (expensive)";
+      optkey   = ["Typeclasses";"Limit";"Intros"];
+      optread  = get_typeclasses_limit_intros;
+      optwrite = set_typeclasses_limit_intros; }
+
+let _ =
+  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 _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "use iterative deepening strategy";
+      optkey   = ["Typeclasses";"Iterative";"Deepening"];
+      optread  = get_typeclasses_iterative_deepening;
+      optwrite = set_typeclasses_iterative_deepening; }
 
-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 _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "compat";
+      optkey   = ["Typeclasses";"Legacy";"Resolution"];
+      optread  = get_typeclasses_legacy_resolution;
+      optwrite = set_typeclasses_legacy_resolution; }
 
-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)
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "compat";
+      optkey   = ["Typeclasses";"Filtered";"Unification"];
+      optread  = get_typeclasses_filtered_unification;
+      optwrite = set_typeclasses_filtered_unification; }
+
+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 _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "debug output for typeclasses proof search";
+      optkey   = ["Debug";"Typeclasses"];
+      optread  = get_typeclasses_debug;
+      optwrite = set_typeclasses_debug; }
+
+let _ =
+  declare_int_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "verbosity of debug output for typeclasses proof search";
+      optkey   = ["Typeclasses";"Debug";"Verbosity"];
+      optread  = get_typeclasses_verbose;
+      optwrite = set_typeclasses_verbose; }
+
+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; }
+
+type search_strategy = Dfs | Bfs
+
+let set_typeclasses_strategy = function
+  | Dfs -> set_typeclasses_iterative_deepening false
+  | Bfs -> set_typeclasses_iterative_deepening true
+
+let pr_ev evs ev =
+  Printer.pr_constr_env (Goal.V82.env evs ev) evs
+                        (Evarutil.nf_evar evs (Goal.V82.concl evs ev))
 
 (** Typeclasses instance search tactic / eauto *)
 
 open Auto
-
 open Unification
 
 let auto_core_unif_flags st freeze = {
@@ -112,7 +210,7 @@ let auto_core_unif_flags st freeze = {
   modulo_eta = !typeclasses_modulo_eta;
 }
 
-let auto_unif_flags freeze st = 
+let auto_unif_flags freeze st =
   let fl = auto_core_unif_flags st freeze in
   { core_unify_flags = fl;
     merge_unify_flags = fl;
@@ -121,182 +219,346 @@ let auto_unif_flags freeze st =
     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, _, _) = c in
   let c, gl =
     if poly then
       let clenv', subst = Clenv.refresh_undefined_univs clenv in
-      let clenv' = connect_clenv gl clenv' in
+      let evd = evars_reset_evd ~with_conv_pbs:true gl.sigma clenv'.evd in
       let c = Vars.subst_univs_level_constr subst c in
-	c, {gl with sigma = clenv'.evd}
+        c, {gl with sigma = evd}
     else c, gl
   in
   let t1 = pf_unsafe_type_of gl c in
-    tclTHEN (Proofview.V82.of_tactic (Clenvtac.unify ~flags t1)) (exact_no_check c) gl
+  Proofview.V82.of_tactic (Clenvtac.unify ~flags t1 <*> exact_no_check c) gl
 
-let unify_e_resolve poly flags (c,clenv) gls =
+let unify_e_resolve poly flags = { enter = begin fun gls (c,_,clenv) ->
   let clenv', c = connect_hint_clenv poly c clenv gls in
   let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in
     Clenvtac.clenv_refine true ~with_classes:false clenv'
+  end }
 
-let unify_resolve poly flags (c,clenv) gls =
+let unify_resolve poly flags = { enter = begin fun gls (c,_,clenv) ->
   let clenv', _ = connect_hint_clenv poly c clenv gls in
   let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in
     Clenvtac.clenv_refine false ~with_classes:false clenv'
-
+  end }
+
+(** Application of a lemma using [refine] instead of the old [w_unify] *)
+let unify_resolve_refine poly flags gls ((c, t, ctx),n,clenv) =
+  let open Clenv in
+  let env = Proofview.Goal.env gls in
+  let concl = Proofview.Goal.concl gls in
+  Refine.refine ~unsafe:true { Sigma.run = fun sigma ->
+      let sigma = Sigma.to_evar_map sigma in
+      let sigma, term, ty =
+        if poly then
+          let (subst, ctx) = Universes.fresh_universe_context_set_instance ctx in
+          let map c = Vars.subst_univs_level_constr subst c in
+          let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in
+          sigma, map c, map t
+        else
+          let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in
+          sigma, c, t
+      in
+      let sigma', cl = Clenv.make_evar_clause env sigma ?len:n ty in
+      let term = applistc term (List.map (fun x -> x.hole_evar) cl.cl_holes) in
+      let sigma' =
+        Evarconv.the_conv_x_leq env ~ts:flags.core_unify_flags.modulo_delta
+                                cl.cl_concl concl sigma'
+      in Sigma.here term (Sigma.Unsafe.of_evar_map sigma') }
+
+let unify_resolve_refine poly flags gl clenv =
+  Proofview.tclORELSE
+    (unify_resolve_refine poly flags gl clenv)
+    (fun ie ->
+      match fst ie with
+      | Evarconv.UnableToUnify _ ->
+         Tacticals.New.tclZEROMSG (str "Unable to unify")
+      | e when CErrors.noncritical e ->
+         Tacticals.New.tclZEROMSG (str "Unexpected error")
+      | _ -> iraise ie)
+
+(** Dealing with goals of the form A -> B and hints of the form
+  C -> A -> B.
+*)
 let clenv_of_prods poly nprods (c, clenv) gl =
   let (c, _, _) = c in
-  if poly || Int.equal nprods 0 then Some clenv
+  if poly || Int.equal nprods 0 then Some (None, clenv)
   else
-    let ty = Tacmach.New.pf_unsafe_type_of gl c in
+    let ty = Retyping.get_type_of (Proofview.Goal.env gl)
+                                  (Sigma.to_evar_map (Proofview.Goal.sigma gl)) c in
     let diff = nb_prod ty - nprods in
-      if Pervasives.(>=) diff 0 then
-        (* Was Some clenv... *)
-	Some (Tacmach.New.of_old (fun gls -> mk_clenv_from_n gls (Some diff) (c,ty)) gl)
-      else None
+    if Pervasives.(>=) diff 0 then
+      (* Was Some clenv... *)
+      Some (Some diff,
+            Tacmach.New.of_old (fun gls -> mk_clenv_from_n gls (Some diff) (c,ty)) gl)
+    else None
 
 let with_prods nprods poly (c, clenv) f =
-  Proofview.Goal.nf_enter (fun gl ->
-  match clenv_of_prods poly nprods (c, clenv) gl with
-  | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses")
-  | Some clenv' -> f (c, clenv') gl)
+  if get_typeclasses_limit_intros () then
+    Proofview.Goal.nf_enter { enter = begin fun gl ->
+      try match clenv_of_prods poly nprods (c, clenv) gl with
+          | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses")
+          | Some (diff, clenv') -> f.enter gl (c, diff, clenv')
+      with e when CErrors.noncritical e ->
+        Tacticals.New.tclZEROMSG (CErrors.print e) end }
+  else Proofview.Goal.nf_enter
+         { enter = begin fun gl ->
+                   if Int.equal nprods 0 then f.enter gl (c, None, clenv)
+                   else Tacticals.New.tclZEROMSG (str"Not enough premisses") end }
+
+let matches_pattern concl pat =
+  let matches env sigma =
+    match pat with
+    | None -> Proofview.tclUNIT ()
+    | Some pat ->
+       let sigma = Sigma.to_evar_map sigma in
+       if Constr_matching.is_matching env sigma pat concl then
+         Proofview.tclUNIT ()
+       else
+         Tacticals.New.tclZEROMSG (str "pattern does not match")
+  in
+   Proofview.Goal.enter { enter = fun gl ->
+     let env = Proofview.Goal.env gl in
+     let sigma = Proofview.Goal.sigma gl in
+       matches env sigma }
+
+(** Semantics of type class resolution lemma application:
+
+  - Use unification to find a well-typed substitution. There might
+    be evars in the goal and the lemma. Evars in the goal can get refined.
+  - Independent evars are turned into goals, whatever their kind is.
+  - Dependent evars of the lemma corresponding to arguments which appear
+    in independent goals or the conclusion are turned into subgoals iff
+    they are of typeclass kind.
+  - The remaining dependent evars not of typeclass type are shelved,
+    and resolution must fill them for it to succeed, otherwise we
+    backtrack.
+ *)
+
+let pr_gls sigma gls =
+  prlist_with_sep spc
+   (fun ev -> int (Evar.repr ev) ++ spc () ++ pr_ev sigma ev) gls
+
+(** Ensure the dependent subgoals are shelved after an apply/eapply. *)
+let shelve_dependencies gls =
+  let open Proofview in
+  tclEVARMAP >>= fun sigma ->
+  (if !typeclasses_debug > 1 && List.length gls > 0 then
+     Feedback.msg_debug (str" shelving dependent subgoals: " ++ pr_gls sigma gls);
+   shelve_goals gls)
+
+let hintmap_of hdc secvars concl =
+  match hdc with
+  | None -> fun db -> Hint_db.map_none secvars db
+  | Some hdc ->
+     fun db ->
+     if Hint_db.use_dn db then (* Using dnet *)
+       Hint_db.map_eauto secvars hdc concl db
+     else Hint_db.map_existential secvars hdc concl db
 
 (** Hack to properly solve dependent evars that are typeclasses *)
-
-let rec e_trivial_fail_db db_list local_db goal =
+let rec e_trivial_fail_db only_classes db_list local_db secvars =
+  let open Tacticals.New in
+  let open Tacmach.New in
+  let trivial_fail =
+    Proofview.Goal.nf_enter { enter =
+    begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Tacmach.New.project gl in
+    let d = pf_last_hyp gl in
+    let hintl = make_resolve_hyp env sigma d in
+    let hints = Hint_db.add_list env sigma hintl local_db in
+      e_trivial_fail_db only_classes db_list hints secvars
+      end }
+  in
+  let trivial_resolve =
+    Proofview.Goal.nf_enter { enter =
+    begin fun gl ->
+    let tacs = e_trivial_resolve db_list local_db secvars only_classes
+                                 (project gl) (pf_concl gl) in
+      tclFIRST (List.map (fun (x,_,_,_,_) -> x) tacs)
+    end}
+  in
   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 (pf_env g') (project g') hintl local_db) g'))) ::
-    (List.map (fun (x,_,_,_,_) -> x) 
-     (e_trivial_resolve db_list local_db (project goal) (pf_concl goal)))
+    (tclTHEN Tactics.intro trivial_fail :: [trivial_resolve])
   in
-  tclFIRST (List.map tclCOMPLETE tacl) goal
+  tclFIRST (List.map tclCOMPLETE tacl)
 
-and e_my_find_search db_list local_db hdc complete sigma concl =
+and e_my_find_search db_list local_db secvars hdc complete only_classes sigma concl =
+  let open Proofview.Notations in
   let prods, concl = decompose_prod_assum concl in
   let nprods = List.length prods in
-  let freeze = 
+  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 e when Errors.noncritical e -> Evar.Set.empty
+      match hdc with
+      | Some (hd,_) when only_classes ->
+         let cl = Typeclasses.class_info hd in
+         if cl.cl_strict then
+           Evd.evars_of_term concl
+         else Evar.Set.empty
+      | _ -> Evar.Set.empty
+    with e when CErrors.noncritical e -> Evar.Set.empty
   in
+  let hint_of_db = hintmap_of hdc secvars concl 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)
+        let tacs = hint_of_db 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}) ->
+    fun (flags, {pri = b; pat = p; poly = poly; code = t; secvars; name = name}) ->
       let tac = function
-      | 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 -> Proofview.V82.tactic (e_give_exact flags poly c)
+        | Res_pf (term,cl) ->
+           if get_typeclasses_filtered_unification () then
+             let tac =
+               with_prods nprods poly (term,cl)
+                          ({ enter = fun gl clenv ->
+                             matches_pattern concl p <*>
+                               unify_resolve_refine poly flags gl clenv})
+             in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable
+           else
+             let tac =
+               with_prods nprods poly (term,cl) (unify_resolve poly flags) in
+             if get_typeclasses_legacy_resolution () then
+               Tacticals.New.tclTHEN tac Proofview.shelve_unifiable
+             else
+               Proofview.tclBIND (Proofview.with_shelf tac)
+                  (fun (gls, ()) -> shelve_dependencies gls)
+        | ERes_pf (term,cl) ->
+           if get_typeclasses_filtered_unification () then
+             let tac = (with_prods nprods poly (term,cl)
+                  ({ enter = fun gl clenv ->
+                             matches_pattern concl p <*>
+                             unify_resolve_refine poly flags gl clenv})) in
+             Tacticals.New.tclTHEN tac Proofview.shelve_unifiable
+           else
+             let tac =
+               with_prods nprods poly (term,cl) (unify_e_resolve poly flags) in
+             if get_typeclasses_legacy_resolution () then
+               Tacticals.New.tclTHEN tac Proofview.shelve_unifiable
+             else
+               Proofview.tclBIND (Proofview.with_shelf tac)
+                  (fun (gls, ()) -> shelve_dependencies gls)
+        | Give_exact (c,clenv) ->
+           if get_typeclasses_filtered_unification () then
+             let tac =
+               matches_pattern concl p <*>
+                 Proofview.Goal.nf_enter
+                   { enter = fun gl -> unify_resolve_refine poly flags gl (c,None,clenv) } in
+             Tacticals.New.tclTHEN tac Proofview.shelve_unifiable
+           else
+             Proofview.V82.tactic (e_give_exact flags poly (c,clenv))
       | Res_pf_THEN_trivial_fail (term,cl) ->
-         Proofview.V82.tactic (tclTHEN
-				 (Proofview.V82.of_tactic ((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 -> Proofview.V82.tactic (tclWEAK_PROGRESS (unfold_in_concl [AllOccurrences,c]))
+         let fst = with_prods nprods poly (term,cl) (unify_e_resolve poly flags) in
+         let snd = if complete then Tacticals.New.tclIDTAC
+                   else e_trivial_fail_db only_classes db_list local_db secvars in
+         Tacticals.New.tclTHEN fst snd
+      | Unfold_nth c ->
+         let tac = Proofview.V82.of_tactic (unfold_in_concl [AllOccurrences,c]) in
+         Proofview.V82.tactic (tclWEAK_PROGRESS tac)
       | Extern tacast -> conclPattern concl p tacast
       in
-      let tac = Proofview.V82.of_tactic (run_hint t tac) in
-      let tac = if complete then tclCOMPLETE tac else tac in
-	match repr_hint t with
-	| Extern _ -> (tac,b,true, name, lazy (pr_hint t))
-	| _ ->
-(* 	  let tac gl = with_pattern (pf_env gl) (project gl) flags p concl tac gl in *)
-	    (tac,b,false, name, lazy (pr_hint t))
+      let tac = run_hint t tac in
+      let tac = if complete then Tacticals.New.tclCOMPLETE tac else tac in
+      let pp =
+        match p with
+        | Some pat when get_typeclasses_filtered_unification () ->
+           str " with pattern " ++ Printer.pr_constr_pattern pat
+        | _ -> mt ()
+      in
+        match repr_hint t with
+        | Extern _ -> (tac, b, true, name, lazy (pr_hint t ++ pp))
+        | _ -> (tac, b, false, name, lazy (pr_hint t ++ pp))
   in List.map tac_of_hint hintl
 
-and e_trivial_resolve db_list local_db sigma concl =
+and e_trivial_resolve db_list local_db secvars only_classes sigma concl =
+  let hd = try Some (decompose_app_bound concl) with Bound -> None in
   try
-    e_my_find_search db_list local_db
-     (decompose_app_bound concl) true sigma concl
-  with Bound | Not_found -> []
+    e_my_find_search db_list local_db secvars hd true only_classes sigma concl
+  with Not_found -> []
 
-let e_possible_resolve db_list local_db sigma concl =
+let e_possible_resolve db_list local_db secvars only_classes sigma concl =
+  let hd = try Some (decompose_app_bound concl) with Bound -> None in
   try
-    e_my_find_search db_list local_db
-      (decompose_app_bound concl) false sigma concl
-  with Bound | Not_found -> []
+    e_my_find_search db_list local_db secvars hd false only_classes sigma concl
+  with Not_found -> []
+
+let cut_of_hints h =
+  List.fold_left (fun cut db -> PathOr (Hint_db.cut db, cut)) PathEmpty h
 
 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
+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
 
-type atac = auto_result tac
+let is_unique env concl =
+  try
+    let (cl,u), args = dest_class_app env concl in
+    cl.cl_unique
+  with e when CErrors.noncritical e -> false
 
-(* Some utility types to avoid the need of -rectypes *)
+(** Sort the undefined variables from the least-dependent to most dependent. *)
+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'
 
-type 'a optionk =
-  | Nonek
-  | Somek of 'a * 'a optionk fk
+(** 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
+*)
 
-type ('a,'b) optionk2 =
-  | Nonek2
-  | Somek2 of 'a * 'b * ('a,'b) optionk2 fk
+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)
 
-let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) =
-  let cty = Evarutil.nf_evar sigma cty in
+(** Making local hints  *)
+let make_resolve_hyp env sigma st flags only_classes pri decl =
+  let open Context.Named.Declaration in
+  let id = get_id decl in
+  let cty = Evarutil.nf_evar sigma (get_type decl) 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
+          let env' = Environ.push_rel_context ctx env in
+          let ty' = whd_all 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
@@ -304,310 +566,832 @@ let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) =
       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 []
+        if is_class then
+          let hints = build_subclasses ~check:false env sigma (VarRef id) empty_hint_info in
+            (List.map_append
+             (fun (path,info,c) ->
+	      let info =
+		{ info with Vernacexpr.hint_pattern =
+			    Option.map (Constrintern.intern_constr_pattern env)
+				       info.Vernacexpr.hint_pattern }
+	      in
+	      make_resolves env sigma ~name:(PathHints path)
+                  (true,false,Flags.is_verbose()) info 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])
+         (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 =
+  let 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
+      (fun hints hyp ->
+        let consider =
+          let open Context.Named.Declaration in
+          try let t = Global.lookup_named (get_id hyp) |> get_type in
+              (* Section variable, reindex only if the type changed *)
+              not (Term.eq_constr t (get_type hyp))
+          with Not_found -> true
+        in
+        if consider then
+          let hint =
+            pf_apply make_resolve_hyp g st (true,false,false) only_classes empty_hint_info hyp
+          in hint @ hints
+        else hints)
+      ([]) sign
   in Hint_db.add_list (pf_env g) (project g) 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') 
-	  && Hint_db.transparent_state cached_hints == st
-	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 env s 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 }
+(** <= 8.5 resolution *)
+module V85 = struct
 
-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
+  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 failure = NotApplicable | ReachedLimit
+  type 'ans fk = failure -> 'ans
+  type ('a,'ans) sk = 'a -> 'ans fk -> 'ans
+  type 'a tac = { skft : 'ans. ('a,'ans) sk -> 'ans fk -> autogoal sigma -> 'ans }
 
-let is_unique env concl = 
-  try 
-    let (cl,u), args = dest_class_app env concl in
-      cl.cl_unique
-  with e when Errors.noncritical e -> 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 ->
-        Control.check_for_interrupt ();
-	(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 })
+  type auto_result = autogoal list sigma
 
+  type atac = auto_result tac
 
-let cut_of_hints h =
-  List.fold_left (fun cut db -> PathOr (Hint_db.cut db, cut)) PathEmpty h
+  (* Some utility types to avoid the need of -rectypes *)
+
+  type 'a optionk =
+    | Nonek
+    | Somek of 'a * 'a optionk fk
+
+  type ('a,'b) optionk2 =
+    | Nonek2 of failure
+    | Somek2 of 'a * 'b * ('a,'b) optionk2 fk
 
-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)
+  let pf_filtered_hyps gls =
+    Goal.V82.hyps gls.Evd.sigma (sig_it gls)
+
+  let make_autogoal_hints =
+    let cache = ref (true, Environ.empty_named_context_val,
+                     Hint_db.empty full_transparent_state true)
     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
+    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')
+         && Hint_db.transparent_state cached_hints == st
+    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 NotApplicable }
+
+  let intro_tac : atac =
+    let tac {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 empty_hint_info (List.hd context) in
+            let ldb = Hint_db.add_list env s hint info.hints in
+            (g', { info with is_evar = None; hints = ldb;
+                             auto_last_tac = lazy (str"intro") })) gls
+      in {it = gls'; sigma = s;}
+    in
+    lift_tactic (Proofview.V82.of_tactic Tactics.intro) tac
+
+  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 merge_failures x y =
+    match x, y with
+    | _, ReachedLimit
+      | ReachedLimit, _ -> ReachedLimit
+    | NotApplicable, NotApplicable -> NotApplicable
+
+  let or_tac (x : 'a tac) (y : 'a tac) : 'a tac =
+    { skft = fun sk fk gls -> x.skft sk
+      (fun f -> y.skft sk (fun f' -> fk (merge_failures f f')) gls) gls }
+
+  let or_else_tac (x : 'a tac) (y : failure -> 'a tac) : 'a tac =
+    { skft = fun sk fk gls -> x.skft sk
+      (fun f -> (y f).skft sk fk gls) gls }
+
+  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 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 secvars = secvars_of_hyps (Environ.named_context_of_val (Goal.V82.hyps s gl)) in
+    let poss = e_possible_resolve hints info.hints secvars info.only_classes s concl in
+    let unique = is_unique env concl in
+    let rec aux i foundone = function
+      | (tac, _, extern, name, pp) :: tl ->
+         let derivs = path_derivate info.auto_cut name in
+         let res =
+           try
+             if path_matches derivs [] then None
+             else Some (Proofview.V82.of_tactic 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 > 0 then
+               Feedback.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 reindex g =
+               let open Goal.V82 in
+               extern && not (Environ.eq_named_context_val
+                             (hyps s' g) (hyps s' gl))
+             in
+             let gl' j (evar, g) =
+               let hints' =
+                 if reindex g then
+                   make_autogoal_hints
+                     info.only_classes
+                     ~st:(Hint_db.transparent_state info.hints)
+                     {it = g; sigma = s';}
+                 else info.hints
+               in
+               { info with
+                 auto_depth = j :: i :: info.auto_depth;
+                 auto_last_tac = pp;
+                 is_evar = evar;
+                 hints = hints';
+                 auto_cut = derivs }
+             in
+             let gls' = List.map_i (fun i g -> snd g, gl' i g) 1 newgls in
+             let glsv = {it = gls'; sigma = s';} in
+             let fk' =
+               (fun e ->
+                 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
+                 let e' = match foundone with None -> e
+                                            | Some e' -> merge_failures e e' in
+                 if !typeclasses_debug > 0 then
+                   Feedback.msg_debug
+                     ((if do_backtrack then str"Backtracking after "
+                       else str "Not backtracking after ")
+                      ++ Lazy.force pp);
+                 if do_backtrack then aux (succ i) (Some e') tl
+                 else fk e')
+             in
+             sk glsv fk')
+      | [] ->
+         if foundone == None && !typeclasses_debug > 0 then
+           Feedback.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");
+         match foundone with
+         | Some e -> fk e
+         | None -> fk NotApplicable
+    in aux 1 None poss
+
+  let hints_tac hints =
+  { skft = fun sk fk gls -> hints_tac hints sk fk gls }
+
+  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 ->
+         Control.check_for_interrupt ();
+         (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 e -> fk e
+         | Somek2 (res, s', fk') ->
+            let goals' = List.concat res in
+            sk {it = goals'; sigma = s'; } (fun e -> aux' (fk' e))
+       in aux' (aux s [] (fun e -> Nonek2 e) 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 reason : atac =
+    { skft = fun sk fk _ -> fk reason }
+
+  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 ReachedLimit
+    else then_tac t { skft = fun sk fk -> (fix_limit (pred limit) t).skft sk fk }
+
+  let fix_iterative t =
+    let rec aux depth =
+      or_else_tac (fix_limit depth t)
+                  (function
+                   | NotApplicable as e -> fail_tac e
+                   | ReachedLimit -> aux (succ depth))
+    in aux 1
+
+  let fix_iterative_limit limit (t : 'a tac) : 'a tac =
+    let rec aux depth =
+      if Int.equal limit depth then fail_tac ReachedLimit
+      else or_tac (fix_limit depth t)
+                  { skft = fun sk fk -> (aux (succ depth)).skft sk fk }
+    in aux 1
+
+  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 make_autogoals ?(only_classes=true) ?(unique=false)
+                     ?(st=full_transparent_state) hints gs evm' =
+    let cut = cut_of_hints hints in
+    let gl 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]})
+    in { it = List.map_i gl 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 strategy depth hints =
+    match strategy with
+    | Bfs -> 
+       begin match depth with
+       | None -> fix_iterative (eauto_tac hints)
+       | Some depth -> fix_iterative_limit depth (eauto_tac hints) end
+    | Dfs ->
+       match depth with
+       | None -> fix (eauto_tac hints)
+       | Some depth -> fix_limit depth (eauto_tac hints)
+                                
+  let real_eauto ?depth strategy unique st hints p evd =
+    let res =
+      run_on_evars ~st ~unique p evd hints (eauto_tac strategy depth hints)
+    in
+    match res with
+    | None -> evd
+    | Some (evd', fk) ->
+       if unique then
+         (match get_result (fk NotApplicable) with
+          | Some (evd'', fk') -> error "Typeclass resolution gives multiple solutions"
+          | None -> evd')
+       else evd'
+
+  let resolve_all_evars_once debug depth unique p evd =
+    let db = searchtable_map typeclasses_db in
+    let strategy = if get_typeclasses_iterative_deepening () then Bfs else Dfs in
+    real_eauto ?depth strategy unique (Hint_db.transparent_state db) [db] p evd
+
+  let eauto85 ?(only_classes=true) ?st ?strategy depth hints g =
+    let strategy =
+      match strategy with
+      | None -> if get_typeclasses_iterative_deepening () then Bfs else Dfs
+      | Some s -> s
+    in
+    let gl = { it = make_autogoal ~only_classes ?st
+                                  (cut_of_hints hints) None g; sigma = project g; } in
+    match run_tac (eauto_tac strategy depth hints) gl with
     | None -> raise Not_found
     | Some {it = goals; sigma = s; } ->
-	{it = List.map fst goals; sigma = s;}
+       {it = List.map fst goals; sigma = s;}
+
+end
+
+(** 8.6 resolution *)
+module Search = struct
+  type autoinfo =
+    { search_depth : int list;
+      last_tac : Pp.std_ppcmds Lazy.t;
+      search_dep : bool;
+      search_only_classes : bool;
+      search_cut : hints_path;
+      search_hints : hint_db; }
+
+  (** Local hints *)
+  let autogoal_cache = ref (DirPath.empty, true, Context.Named.empty,
+                            Hint_db.empty full_transparent_state true)
+
+  let make_autogoal_hints only_classes ?(st=full_transparent_state) g =
+    let open Proofview in
+    let open Tacmach.New in
+    let sign = Goal.hyps g in
+    let (dir, onlyc, sign', cached_hints) = !autogoal_cache in
+    let cwd = Lib.cwd () in
+    if DirPath.equal cwd dir &&
+         (onlyc == only_classes) &&
+           Context.Named.equal sign sign' &&
+             Hint_db.transparent_state cached_hints == st
+    then cached_hints
+    else
+      let hints = make_hints {it = Goal.goal g; sigma = project g}
+                             st only_classes sign
+      in
+      autogoal_cache := (cwd, only_classes, sign, hints); hints
+
+  let make_autogoal ?(st=full_transparent_state) only_classes dep cut i g =
+    let hints = make_autogoal_hints only_classes ~st g in
+    { search_hints = hints;
+      search_depth = [i]; last_tac = lazy (str"none");
+      search_dep = dep;
+      search_only_classes = only_classes;
+      search_cut = cut }
+
+  (** In the proof engine failures are represented as exceptions *)
+  exception ReachedLimitEx
+  exception NotApplicableEx
+
+  (** ReachedLimitEx has priority over NotApplicableEx to handle
+      iterative deepening: it should fail when no hints are applicable,
+      but go to a deeper depth otherwise. *)
+  let merge_exceptions e e' =
+    match fst e, fst e' with
+    | ReachedLimitEx, _ -> e
+    | _, ReachedLimitEx -> e'
+    | _, _ -> e
+
+  (** Determine if backtracking is needed for this goal.
+      If the type class is unique or in Prop
+      and there are no evars in the goal then we do
+      NOT backtrack. *)
+  let needs_backtrack env evd unique concl =
+    if unique || is_Prop env evd concl then
+      occur_existential concl
+    else true
 
-let real_eauto ?limit unique st hints p evd =
-  let res =
-    run_on_evars ~st ~unique p evd hints (eauto_tac ?limit hints)
-  in
+  let mark_unresolvables sigma goals =
+    List.fold_left
+      (fun sigma gl ->
+        let evi = Evd.find_undefined sigma gl in
+	let evi' = Typeclasses.mark_unresolvable evi in
+	Evd.add sigma gl evi')
+      sigma goals
+
+  let fail_if_nonclass info =
+    Proofview.Goal.enter { enter = fun gl ->
+      let gl = Proofview.Goal.assume gl in
+      let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in
+      if is_class_type sigma (Proofview.Goal.concl gl) then
+        Proofview.tclUNIT ()
+      else (if !typeclasses_debug > 1 then
+              Feedback.msg_debug (pr_depth info.search_depth ++
+                                    str": failure due to non-class subgoal " ++
+                                    pr_ev sigma (Proofview.Goal.goal gl));
+            Proofview.tclZERO NotApplicableEx) }
+
+  (** The general hint application tactic.
+      tac1 + tac2 .... The choice of OR or ORELSE is determined
+      depending on the dependencies of the goal and the unique/Prop
+      status *)
+  let hints_tac_gl hints info kont gl : unit Proofview.tactic =
+    let open Proofview in
+    let open Proofview.Notations in
+    let env = Goal.env gl in
+    let concl = Goal.concl gl in
+    let sigma = Goal.sigma gl in
+    let s = Sigma.to_evar_map sigma in
+    let unique = not info.search_dep || is_unique env concl in
+    let backtrack = needs_backtrack env s unique concl in
+    if !typeclasses_debug > 0 then
+      Feedback.msg_debug
+        (pr_depth info.search_depth ++ str": looking for " ++
+           Printer.pr_constr_env (Goal.env gl) s concl ++
+           (if backtrack then str" with backtracking"
+            else str" without backtracking"));
+    let secvars = compute_secvars gl in
+    let poss =
+      e_possible_resolve hints info.search_hints secvars info.search_only_classes s concl in
+    (* If no goal depends on the solution of this one or the
+       instances are irrelevant/assumed to be unique, then
+       we don't need to backtrack, as long as no evar appears in the goal
+       This is an overapproximation. Evars could appear in this goal only
+       and not any other *)
+    let ortac = if backtrack then Proofview.tclOR else Proofview.tclORELSE in
+    let idx = ref 1 in
+    let foundone = ref false in
+    let rec onetac e (tac, pat, b, name, pp) tl =
+      let derivs = path_derivate info.search_cut name in
+      let pr_error ie =
+        if !typeclasses_debug > 1 then
+          let msg =
+            pr_depth (!idx :: info.search_depth) ++ str": " ++
+              Lazy.force pp ++
+              (if !foundone != true then
+                 str" on" ++ spc () ++ pr_ev s (Proofview.Goal.goal gl)
+               else mt ())
+          in
+          Feedback.msg_debug (msg ++ str " failed with " ++ CErrors.iprint ie)
+        else ()
+      in
+      let tac_of gls i j = Goal.nf_enter { enter = fun gl' ->
+        let sigma' = Goal.sigma gl' in
+        let s' = Sigma.to_evar_map sigma' in
+        let _concl = Goal.concl gl' in
+        if !typeclasses_debug > 0 then
+          Feedback.msg_debug
+            (pr_depth (succ j :: i :: info.search_depth) ++ str" : " ++
+               pr_ev s' (Proofview.Goal.goal gl'));
+        let hints' =
+          if b && not (Context.Named.equal (Goal.hyps gl') (Goal.hyps gl))
+          then
+            let st = Hint_db.transparent_state info.search_hints in
+            make_autogoal_hints info.search_only_classes ~st gl'
+          else info.search_hints
+        in
+        let dep' = info.search_dep || Proofview.unifiable s' (Goal.goal gl') gls in
+        let info' =
+          { search_depth = succ j :: i :: info.search_depth;
+            last_tac = pp;
+            search_dep = dep';
+            search_only_classes = info.search_only_classes;
+            search_hints = hints';
+            search_cut = derivs }
+        in kont info' }
+      in
+      let rec result (shelf, ()) i k =
+        foundone := true;
+        Proofview.Unsafe.tclGETGOALS >>= fun gls ->
+        let j = List.length gls in
+        (if !typeclasses_debug > 0 then
+           Feedback.msg_debug
+             (pr_depth (i :: info.search_depth) ++ str": " ++ Lazy.force pp
+              ++ str" on" ++ spc () ++ pr_ev s (Proofview.Goal.goal gl)
+              ++ str", " ++ int j ++ str" subgoal(s)" ++
+                (Option.cata (fun k -> str " in addition to the first " ++ int k)
+                             (mt()) k)));
+        let res =
+          if j = 0 then tclUNIT ()
+          else tclDISPATCH
+                 (List.init j (fun j' -> (tac_of gls i (Option.default 0 k + j))))
+        in
+        let finish nestedshelf sigma =
+          let filter ev =
+            try
+              let evi = Evd.find_undefined sigma ev in
+              if info.search_only_classes then
+                Some (ev, not (is_class_type sigma (Evd.evar_concl evi)))
+              else Some (ev, true)
+            with Not_found -> None
+          in
+          let remaining = CList.map_filter filter shelf in
+          (if !typeclasses_debug > 1 then
+             let prunsolved (ev, _) =
+               int (Evar.repr ev) ++ spc () ++ pr_ev sigma ev in
+             let unsolved = prlist_with_sep spc prunsolved remaining in
+             Feedback.msg_debug
+               (pr_depth (i :: info.search_depth) ++
+                  str": after " ++ Lazy.force pp ++ str" finished, " ++
+                  int (List.length remaining) ++
+                  str " goals are shelved and unsolved ( " ++
+                  unsolved ++ str")"));
+          begin
+            (* Some existentials produced by the original tactic were not solved
+               in the subgoals, turn them into subgoals now. *)
+            let shelved, goals = List.partition (fun (ev, s) -> s) remaining in
+            let shelved = List.map fst shelved @ nestedshelf and goals = List.map fst goals in
+            if !typeclasses_debug > 1 && not (List.is_empty shelved && List.is_empty goals) then
+              Feedback.msg_debug
+                (str"Adding shelved subgoals to the search: " ++
+                 prlist_with_sep spc (pr_ev sigma) goals ++
+		 str" while shelving " ++
+		 prlist_with_sep spc (pr_ev sigma) shelved);
+            shelve_goals shelved <*>
+              (if List.is_empty goals then tclUNIT ()
+               else
+	         let sigma' = mark_unresolvables sigma goals in
+	         with_shelf (Unsafe.tclEVARS sigma' <*> Unsafe.tclNEWGOALS goals) >>=
+                      fun s -> result s i (Some (Option.default 0 k + j)))
+          end
+        in with_shelf res >>= fun (sh, ()) ->
+           tclEVARMAP >>= finish sh
+      in
+      if path_matches derivs [] then aux e tl
+      else
+        let filter =
+          if false (* in 8.6, still allow non-class subgoals
+                    info.search_only_classes *) then fail_if_nonclass info
+          else Proofview.tclUNIT ()
+        in
+        ortac
+             (with_shelf (tac <*> filter) >>= fun s ->
+              let i = !idx in incr idx; result s i None)
+             (fun e' ->
+	      if CErrors.noncritical (fst e') then
+                (pr_error e'; aux (merge_exceptions e e') tl)
+              else iraise e')
+    and aux e = function
+      | x :: xs -> onetac e x xs
+      | [] ->
+         if !foundone == false && !typeclasses_debug > 0 then
+           Feedback.msg_debug
+             (pr_depth info.search_depth ++ str": no match for " ++
+                Printer.pr_constr_env (Goal.env gl) s concl ++
+                spc () ++ str ", " ++ int (List.length poss) ++
+                str" possibilities");
+         match e with
+         | (ReachedLimitEx,ie) -> Proofview.tclZERO ~info:ie ReachedLimitEx
+         | (_,ie) -> Proofview.tclZERO ~info:ie NotApplicableEx
+    in
+    if backtrack then aux (NotApplicableEx,Exninfo.null) poss
+    else tclONCE (aux (NotApplicableEx,Exninfo.null) poss)
+
+  let hints_tac hints info kont : unit Proofview.tactic =
+    Proofview.Goal.nf_enter
+      { enter = fun gl -> hints_tac_gl hints info kont gl }
+
+  let intro_tac info kont gl =
+    let open Proofview in
+    let open Proofview.Notations in
+    let env = Goal.env gl in
+    let sigma = Goal.sigma gl in
+    let s = Sigma.to_evar_map sigma in
+    let decl = Tacmach.New.pf_last_hyp gl in
+    let hint =
+      make_resolve_hyp env s (Hint_db.transparent_state info.search_hints)
+                       (true,false,false) info.search_only_classes empty_hint_info decl in
+    let ldb = Hint_db.add_list env s hint info.search_hints in
+    let info' =
+      { info with search_hints = ldb; last_tac = lazy (str"intro");
+        search_depth = 1 :: 1 :: info.search_depth }
+    in kont info'
+
+  let intro info kont =
+    Proofview.tclBIND Tactics.intro
+     (fun _ -> Proofview.Goal.nf_enter { enter = fun gl -> intro_tac info kont gl })
+
+  let rec search_tac hints limit depth =
+    let kont info =
+      Proofview.numgoals >>= fun i ->
+      if !typeclasses_debug > 1 then
+        Feedback.msg_debug
+          (str"calling eauto recursively at depth " ++ int (succ depth)
+           ++ str" on " ++ int i ++ str" subgoals");
+      search_tac hints limit (succ depth) info
+    in
+    fun info ->
+    if Int.equal depth (succ limit) then Proofview.tclZERO ReachedLimitEx
+    else
+      Proofview.tclOR (hints_tac hints info kont)
+                      (fun e -> Proofview.tclOR (intro info kont)
+                      (fun e' -> let (e, info) = merge_exceptions e e' in
+                              Proofview.tclZERO ~info e))
+
+  let search_tac_gl ?st only_classes dep hints depth i sigma gls gl :
+        unit Proofview.tactic =
+    let open Proofview in
+    let open Proofview.Notations in
+    if false (* In 8.6, still allow non-class goals only_classes && not (is_class_type sigma (Goal.concl gl)) *) then
+      Tacticals.New.tclZEROMSG (str"Not a subgoal for a class")
+    else
+      let dep = dep || Proofview.unifiable sigma (Goal.goal gl) gls in
+      let info = make_autogoal ?st only_classes dep (cut_of_hints hints) i gl in
+      search_tac hints depth 1 info
+
+  let search_tac ?(st=full_transparent_state) only_classes dep hints depth =
+    let open Proofview in
+    let tac sigma gls i =
+      Goal.nf_enter
+        { enter = fun gl ->
+          search_tac_gl ~st only_classes dep hints depth (succ i) sigma gls gl }
+    in
+      Proofview.Unsafe.tclGETGOALS >>= fun gls ->
+      Proofview.tclEVARMAP >>= fun sigma ->
+      let j = List.length gls in
+      (tclDISPATCH (List.init j (fun i -> tac sigma gls i)))
+
+  let fix_iterative t =
+    let rec aux depth =
+      Proofview.tclOR
+        (t depth)
+        (function
+         | (ReachedLimitEx,_) -> aux (succ depth)
+         | (e,ie) -> Proofview.tclZERO ~info:ie e)
+    in aux 1
+
+  let fix_iterative_limit limit t =
+    let open Proofview in
+    let rec aux depth =
+      if Int.equal depth (succ limit) then tclZERO ReachedLimitEx
+      else tclOR (t depth) (function (ReachedLimitEx, _) -> aux (succ depth)
+                                   | (e,ie) -> Proofview.tclZERO ~info:ie e)
+    in aux 1
+
+  let eauto_tac ?(st=full_transparent_state) ?(unique=false)
+                ~only_classes ?strategy ~depth ~dep hints =
+    let open Proofview in
+    let tac =
+      let search = search_tac ~st only_classes dep hints in
+      let dfs =
+        match strategy with
+        | None -> not (get_typeclasses_iterative_deepening ())
+        | Some Dfs -> true
+        | Some Bfs -> false
+      in
+      if dfs then
+        let depth = match depth with None -> -1 | Some d -> d in
+        search depth
+      else
+        match depth with
+        | None -> fix_iterative search
+        | Some l -> fix_iterative_limit l search
+    in
+    let error (e, ie) =
+      match e with
+      | ReachedLimitEx ->
+         Tacticals.New.tclFAIL 0 (str"Proof search reached its limit")
+      | NotApplicableEx ->
+         Tacticals.New.tclFAIL 0 (str"Proof search failed" ++
+                                    (if Option.is_empty depth then mt()
+                                     else str" without reaching its limit"))
+      | Proofview.MoreThanOneSuccess ->
+         Tacticals.New.tclFAIL 0 (str"Proof search failed: " ++
+                                  str"more than one success found")
+      | e -> Proofview.tclZERO ~info:ie e
+    in
+    let tac = Proofview.tclOR tac error in
+    let tac =
+      if unique then
+        Proofview.tclEXACTLY_ONCE Proofview.MoreThanOneSuccess tac
+      else tac
+    in
+    with_shelf numgoals >>= fun (initshelf, i) ->
+    (if !typeclasses_debug > 1 then
+       Feedback.msg_debug (str"Starting resolution with " ++ int i ++
+                             str" goal(s) under focus and " ++
+                             int (List.length initshelf) ++ str " shelved goal(s)" ++
+                             (if only_classes then str " in only_classes mode" else str " in regular mode") ++
+                             match depth with None -> str ", unbounded"
+                                            | Some i -> str ", with depth limit " ++ int i));
+    tac
+
+  let run_on_evars p evm 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 fgoals = Evd.future_goals evm in
+       let pgoal = Evd.principal_future_goal evm in
+       let _, pv = Proofview.init evm' [] in
+       let pv = Proofview.unshelve goals pv in
+       try
+         let (), pv', (unsafe, shelved, gaveup), _ =
+           Proofview.apply (Global.env ()) tac pv
+         in
+         if Proofview.finished pv' then
+           let evm' = Proofview.return pv' in
+           assert(Evd.fold_undefined (fun ev _ acc ->
+                      let okev = Evd.mem evm ev || List.mem ev shelved in
+                      if not okev then
+                        Feedback.msg_debug
+                          (str "leaking evar " ++ int (Evar.repr ev) ++
+                             spc () ++ pr_ev evm' ev);
+                      acc && okev) evm' true);
+           let evm' = Evd.restore_future_goals evm' (shelved @ fgoals) pgoal in
+           let evm' = evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm in
+           Some evm'
+         else raise Not_found
+       with Logic_monad.TacticFailure _ -> raise Not_found
+
+  let evars_eauto depth only_classes unique dep st hints p evd =
+    let eauto_tac = eauto_tac ~st ~unique ~only_classes ~depth ~dep:(unique || dep) hints in
+    let res = run_on_evars p evd eauto_tac 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
+    | Some evd' -> evd'
+
+  let typeclasses_eauto ?depth unique st hints p evd =
+    evars_eauto depth true unique false st hints p evd
+  (** Typeclasses eauto is an eauto which tries to resolve only
+      goals of typeclass type, and assumes that the initially selected
+      evars in evd are independent of the rest of the evars *)
+
+  let typeclasses_resolve debug depth unique p evd =
+    let db = searchtable_map typeclasses_db in
+    typeclasses_eauto ?depth unique (Hint_db.transparent_state db) [db] p evd
+end
+
+(** Binding to either V85 or Search implementations. *)
+
+let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state)
+                      ?strategy ~depth dbs =
+  let dbs = List.map_filter
+              (fun db -> try Some (searchtable_map db)
+                      with e when CErrors.noncritical e -> None)
+              dbs
+  in
+  let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in
+  let depth = match depth with None -> get_typeclasses_depth () | Some l -> Some l in
+  if get_typeclasses_legacy_resolution () then
+    Proofview.V82.tactic
+    (fun gl ->
+      try V85.eauto85 depth ~only_classes ~st ?strategy dbs gl
+      with Not_found ->
+	Refiner.tclFAIL 0 (str"Proof search failed") gl)
+  else Search.eauto_tac ~st ~only_classes ?strategy ~depth ~dep:true dbs
 
 (** We compute dependencies via a union-find algorithm.
     Beware of the imperative effects on the partition structure,
@@ -629,24 +1413,6 @@ let evar_dependencies evm p =
       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 =
@@ -662,9 +1428,9 @@ let is_inference_forced p evd ev =
     then
       let (loc, k) = evar_source ev evd in
       match k with
-	| Evar_kinds.ImplicitArg (_, _, b) -> b
-	| Evar_kinds.QuestionMark _ -> false
-	| _ -> true
+        | Evar_kinds.ImplicitArg (_, _, b) -> b
+        | Evar_kinds.QuestionMark _ -> false
+        | _ -> true
     else true
   with Not_found -> assert false
 
@@ -731,12 +1497,11 @@ let revert_resolvability oevd evd =
   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 =
+(** If [do_split] is [true], we try to separate the problem in
+    several components and then solve them separately *)
+let resolve_all_evars debug depth 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
@@ -745,16 +1510,21 @@ let resolve_all_evars debug m unique env p oevd do_split fail =
     | 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
+        let evd' =
+          if get_typeclasses_legacy_resolution () then
+            V85.resolve_all_evars_once debug depth unique p evd
+          else
+            Search.typeclasses_resolve debug depth 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. *)
+        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
+          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 =
@@ -762,61 +1532,51 @@ let initial_select_evars filter =
     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 resolve_typeclass_evars debug depth unique env evd filter split fail =
   let evd =
-    try Evarconv.consider_remaining_unif_problems
+    try Evarconv.solve_unif_constraints_with_heuristics
       ~ts:(Typeclasses.classes_transparent_state ()) env evd
-    with e when Errors.noncritical e -> evd
+    with e when CErrors.noncritical e -> evd
   in
-    resolve_all_evars debug m unique env (initial_select_evars filter) evd split fail
+    resolve_all_evars debug depth 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 solve_inst env evd filter unique split fail =
+  resolve_typeclass_evars
+    (get_typeclasses_debug ())
+    (get_typeclasses_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
+  Hook.set Typeclasses.solve_all_instances_hook solve_inst
 
-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 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 st = Hint_db.transparent_state hints in
+  let depth = get_typeclasses_depth () in
+  let gls' =
+    if get_typeclasses_legacy_resolution () then
+      V85.eauto85 depth ~st [hints] gls
+    else
+      try
+        Proofview.V82.of_tactic
+        (Search.eauto_tac ~st ~only_classes:true ~depth [hints] ~dep:true) gls
+      with Refiner.FailError _ -> raise Not_found
+  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_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
+let _ =
+  Hook.set Typeclasses.solve_one_instance_hook
+    (fun x y z w -> resolve_one_typeclass x ~sigma:y z w)
 
 (** Take the head of the arity of a constr.
     Used in the partial application tactic. *)
@@ -833,18 +1593,21 @@ 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 not_evar c =
+  Proofview.tclEVARMAP >>= fun sigma ->
+  match Evarutil.kind_of_term_upto sigma 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 
+  let flags = auto_unif_flags Evar.Set.empty
     (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in
   let cty = pf_unsafe_type_of gl c in
   let ce = mk_clenv_from gl (c,cty) in
-  let tac = unify_e_resolve false flags ((c,cty,Univ.ContextSet.empty),ce) in
+  let tac = { enter = fun gl -> (unify_e_resolve false flags).enter gl
+    ((c,cty,Univ.ContextSet.empty),0,ce) } in
   Proofview.V82.of_tactic (Proofview.Goal.nf_enter tac) gl
diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli
index f1bcfa7d..76760db0 100644
--- a/tactics/class_tactics.mli
+++ b/tactics/class_tactics.mli
@@ -6,6 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(** This files implements typeclasses eauto *)
+
 open Names
 open Constr
 open Tacmach
@@ -18,10 +20,13 @@ 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
+type search_strategy = Dfs | Bfs
+
+val set_typeclasses_strategy : search_strategy -> unit
 
-val typeclasses_eauto : ?only_classes:bool -> ?st:transparent_state ->
-  Hints.hint_db_name list -> tactic
+val typeclasses_eauto : ?only_classes:bool -> ?st:transparent_state -> ?strategy:search_strategy ->
+                        depth:(Int.t option) ->
+                        Hints.hint_db_name list -> unit Proofview.tactic
 
 val head_of_constr : Id.t -> Term.constr -> unit Proofview.tactic
 
@@ -30,3 +35,23 @@ val not_evar : constr -> unit Proofview.tactic
 val is_ground : constr -> tactic
 
 val autoapply : constr -> Hints.hint_db_name -> tactic
+
+module Search : sig
+  val eauto_tac :
+    ?st:Names.transparent_state ->
+    (** The transparent_state used when working with local hypotheses  *)
+    ?unique:bool ->
+    (** Should we force a unique solution *)
+    only_classes:bool ->
+    (** Should non-class goals be shelved and resolved at the end *)
+    ?strategy:search_strategy ->
+    (** Is a traversing-strategy specified? *)
+    depth:Int.t option ->
+    (** Bounded or unbounded search *)
+    dep:bool ->
+    (** Should the tactic be made backtracking on the initial goals,
+       whatever their internal dependencies are. *)
+    Hints.hint_db list ->
+    (** The list of hint databases to use *)
+    unit Proofview.tactic
+end
diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml
index 6eebf494..445a104d 100644
--- a/tactics/contradiction.ml
+++ b/tactics/contradiction.ml
@@ -6,13 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
 open Term
 open Hipattern
 open Tactics
 open Coqlib
 open Reductionops
 open Misctypes
+open Proofview.Notations
+open Context.Named.Declaration
 
 (* Absurd *)
 
@@ -22,53 +23,73 @@ let mk_absurd_proof 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
+  Proofview.Goal.s_enter { s_enter = begin fun gl ->
     let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    let sigma = Sigma.to_evar_map sigma 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
+    let tac =
     Tacticals.New.tclTHENLIST [
-      Proofview.Unsafe.tclEVARS sigma;
       elim_type (build_coq_False ());
       Simple.apply (mk_absurd_proof t)
-    ]
-  end
+    ] in
+    Sigma.Unsafe.of_pair (tac, sigma)
+  end }
 
 let absurd c = absurd c
 
 (* Contradiction *)
 
+let use_negated_unit_or_eq_type () = Flags.version_strictly_greater Flags.V8_5
+
 (** [f] does not assume its argument to be [nf_evar]-ed. *)
 let filter_hyp f tac =
   let rec seek = function
     | [] -> Proofview.tclZERO Not_found
-    | (id,_,t)::rest when f t -> tac id
+    | d::rest when f (get_type d) -> tac (get_id d)
     | _::rest -> seek rest in
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
     let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in
     seek hyps
-  end
+  end }
 
 let contradiction_context =
-  Proofview.Goal.enter begin fun gl ->
-    let sigma = Proofview.Goal.sigma gl in
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let sigma = Tacmach.New.project gl in
     let env = Proofview.Goal.env gl in
     let rec seek_neg l = match l with
       | [] ->  Tacticals.New.tclZEROMSG (Pp.str"No such contradiction")
-      | (id,_,typ)::rest ->
-          let typ = nf_evar sigma typ in
-	  let typ = whd_betadeltaiota env sigma typ in
+      | d :: rest ->
+          let id = get_id d in
+          let typ = nf_evar sigma (get_type d) in
+	  let typ = whd_all 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 ->
+             let is_unit_or_eq =
+               if use_negated_unit_or_eq_type () then match_with_unit_or_eq_type t
+               else None in
+	     Tacticals.New.tclORELSE
+               (match is_unit_or_eq with
+               | Some _ ->
+                   let hd,args = decompose_app t in
+                   let (ind,_ as indu) = destInd hd in
+                   let nparams = Inductiveops.inductive_nparams_env env ind in
+                   let params = Util.List.firstn nparams args in
+                   let p = applist ((mkConstructUi (indu,1)), params) in
+                   (* Checking on the fly that it type-checks *)
+                   simplest_elim (mkApp (mkVar id,[|p|]))
+               | None ->
+                 Tacticals.New.tclZEROMSG (Pp.str"Not a negated unit type."))
 	      (Proofview.tclORELSE
-                 (Proofview.Goal.enter begin fun gl ->
+                 (Proofview.Goal.enter { 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)
+                 end })
                  begin function (e, info) -> match e with
 	           | Not_found -> seek_neg rest
                    | e -> Proofview.tclZERO ~info e
@@ -77,18 +98,18 @@ let contradiction_context =
     in
     let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in
     seek_neg hyps
-  end
+  end }
 
 let is_negation_of env sigma typ t =
-  match kind_of_term (whd_betadeltaiota env sigma t) with
+  match kind_of_term (whd_all env sigma t) with
     | 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) =
-  Proofview.Goal.nf_enter begin fun gl ->
-    let sigma = Proofview.Goal.sigma gl in
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
+    let sigma = Tacmach.New.project gl in
     let env = Proofview.Goal.env gl in
     let type_of = Tacmach.New.pf_unsafe_type_of gl in
     let typ = type_of c in
@@ -110,7 +131,7 @@ let contradiction_term (c,lbind as cl) =
           | Not_found -> Tacticals.New.tclZEROMSG (Pp.str"Not a contradiction.")
           | e -> Proofview.tclZERO ~info e
         end
-  end
+  end }
 
 let contradiction = function
   | None -> Tacticals.New.tclTHEN intros contradiction_context
diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml
index 568b1d17..23ff5822 100644
--- a/tactics/eauto.ml4
+++ b/tactics/eauto.ml
@@ -6,10 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "grammar/grammar.cma" i*)
-
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
@@ -19,42 +17,38 @@ open Proof_type
 open Tacticals
 open Tacmach
 open Tactics
-open Patternops
 open Clenv
 open Auto
 open Genredexpr
 open Tacexpr
-open Misctypes
 open Locus
 open Locusops
 open Hints
-
-DECLARE PLUGIN "eauto"
+open Proofview.Notations
 
 let eauto_unif_flags = auto_flags_of_state full_transparent_state
 
-let e_give_exact ?(flags=eauto_unif_flags) c gl =
-  let t1 = (pf_unsafe_type_of gl c) and t2 = pf_concl gl in
+let e_give_exact ?(flags=eauto_unif_flags) c =
+  Proofview.Goal.enter { enter = begin fun gl ->
+  let t1 = Tacmach.New.pf_unsafe_type_of gl c in
+  let t2 = Tacmach.New.pf_concl (Proofview.Goal.assume gl) in
   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
+     Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c)
+  else exact_check c
+  end }
 
 let assumption id = e_give_exact (mkVar id)
 
-let e_assumption gl =
-  tclFIRST (List.map assumption (pf_ids_of_hyps gl)) gl
-
-TACTIC EXTEND eassumption
-| [ "eassumption" ] -> [ Proofview.V82.tactic e_assumption ]
-END
+let e_assumption =
+  Proofview.Goal.enter { enter = begin fun gl ->
+    Tacticals.New.tclFIRST (List.map assumption (Tacmach.New.pf_ids_of_hyps gl))
+  end }
 
-TACTIC EXTEND eexact
-| [ "eexact" constr(c) ] -> [ Proofview.V82.tactic (e_give_exact c) ]
-END
-
-let registered_e_assumption gl =
-  tclFIRST (List.map (fun id gl -> e_give_exact (mkVar id) gl)
-              (pf_ids_of_hyps gl)) gl
+let registered_e_assumption =
+  Proofview.Goal.enter { enter = begin fun gl ->
+  Tacticals.New.tclFIRST (List.map (fun id -> e_give_exact (mkVar id))
+              (Tacmach.New.pf_ids_of_hyps gl))
+  end }
 
 (************************************************************************)
 (*   PROLOG tactic                                                      *)
@@ -83,7 +77,7 @@ let one_step l gl =
   [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))
+  @ (List.map (fun c -> Proofview.V82.of_tactic (assumption c)) (pf_ids_of_hyps gl))
 
 let rec prolog l n gl =
   if n <= 0 then error "prolog - failure";
@@ -94,71 +88,72 @@ 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 (fun x -> out_term (pf_apply (prepare_hint false (false,true)) gl x)) l in
-  let n =
-    match n with
-      | ArgArg n -> n
-      | _ -> error "Prolog called with a non closed argument."
+let prolog_tac l n =
+  Proofview.V82.tactic begin fun gl ->
+  let map c =
+    let (c, sigma) = Tactics.run_delayed (pf_env gl) (project gl) c in
+    let c = pf_apply (prepare_hint false (false,true)) gl (sigma, c) in
+    out_term c
   in
+  let l = List.map map l in
   try (prolog l n gl)
   with UserError ("Refiner.tclFIRST",_) ->
     errorlabstrm "Prolog.prolog" (str "Prolog failed.")
-
-TACTIC EXTEND prolog
-| [ "prolog" "[" open_constr_list(l) "]" int_or_var(n) ] -> [ Proofview.V82.tactic (prolog_tac l n) ]
-END
+  end
 
 open Auto
-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,_) -> Int.equal pr 0) l)
-			  
+
 let unify_e_resolve poly flags (c,clenv) =
-  Proofview.Goal.nf_enter begin
-      fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
       let clenv', c = connect_hint_clenv poly c clenv gl in
       Proofview.V82.tactic
 	(fun gls ->
 	 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 c)) gls)
-    end
+    end }
 
-let hintmap_of hdc concl =
+let hintmap_of secvars hdc concl =
   match hdc with
-  | None -> fun db -> Hint_db.map_none db
+  | None -> fun db -> Hint_db.map_none ~secvars db
   | Some hdc ->
-    if occur_existential concl then (fun db -> Hint_db.map_existential hdc concl db)
-    else (fun db -> Hint_db.map_auto hdc concl db)
+     if occur_existential concl then
+       (fun db -> Hint_db.map_existential ~secvars hdc concl db)
+     else (fun db -> Hint_db.map_auto ~secvars hdc concl db)
    (* FIXME: should be (Hint_db.map_eauto hdc concl db) *)
 
 let e_exact poly flags (c,clenv) =
-  let (c, _, _) = c in
-  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 =
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let clenv', c = connect_hint_clenv poly c clenv gl in
+    Tacticals.New.tclTHEN
+    (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd))
+    (e_give_exact c)
+  end }
+
+let rec e_trivial_fail_db db_list local_db =
+  let next = Proofview.Goal.nf_enter { enter = begin fun gl ->
+    let d = Tacmach.New.pf_last_hyp gl in
+    let hintl = make_resolve_hyp (Tacmach.New.pf_env gl) (Tacmach.New.project gl) d in
+    e_trivial_fail_db db_list (Hint_db.add_list (Tacmach.New.pf_env gl) (Tacmach.New.project gl) hintl local_db)
+  end } in
+  Proofview.Goal.enter { enter = begin fun gl ->
+  let secvars = compute_secvars gl in
   let tacl =
     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 (pf_env g') (project g') hintl local_db) g'))) ::
-    (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) )
+    (Tacticals.New.tclTHEN Tactics.intro next) ::
+    (List.map fst (e_trivial_resolve db_list local_db secvars (Tacmach.New.pf_nf_concl gl)))
   in
-    tclFIRST (List.map tclCOMPLETE tacl) goal
+  Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl)
+  end }
 
-and e_my_find_search db_list local_db hdc concl =
-  let hint_of_db = hintmap_of hdc concl in
+and e_my_find_search db_list local_db secvars hdc concl =
+  let hint_of_db = hintmap_of secvars hdc concl in
   let hintl =
       List.map_append (fun db ->
 	let flags = auto_flags_of_state (Hint_db.transparent_state db) in
@@ -174,26 +169,27 @@ and e_my_find_search db_list local_db hdc concl =
         let tac = function
         | Res_pf (term,cl) -> unify_resolve poly st (term,cl)
         | ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl)
-        | Give_exact (c,cl) -> Proofview.V82.tactic (e_exact poly st (c,cl))
+        | Give_exact (c,cl) -> e_exact poly st (c,cl)
         | Res_pf_THEN_trivial_fail (term,cl) ->
-          Proofview.V82.tactic (tclTHEN (Proofview.V82.of_tactic (unify_e_resolve poly st (term,cl)))
-            (e_trivial_fail_db db_list local_db))
-        | Unfold_nth c -> Proofview.V82.tactic (reduce (Unfold [AllOccurrences,c]) onConcl)
+          Tacticals.New.tclTHEN (unify_e_resolve poly st (term,cl))
+            (e_trivial_fail_db db_list local_db)
+        | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl
         | Extern tacast -> conclPattern concl p tacast
        in
-       let tac = Proofview.V82.of_tactic (run_hint t tac) in
+       let tac = run_hint t tac in
        (tac, lazy (pr_hint t)))
   in
   List.map tac_of_hint hintl
 
-and e_trivial_resolve db_list local_db gl =
+and e_trivial_resolve db_list local_db secvars gl =
   let hd = try Some (decompose_app_bound gl) with Bound -> None in
-  try priority (e_my_find_search db_list local_db hd gl)
+  try priority (e_my_find_search db_list local_db secvars hd gl)
   with Not_found -> []
 
-let e_possible_resolve db_list local_db gl =
+let e_possible_resolve db_list local_db secvars gl =
   let hd = try Some (decompose_app_bound gl) with Bound -> None in
-  try List.map (fun (b, (tac, pp)) -> (tac, b, pp)) (e_my_find_search db_list local_db hd gl)
+  try List.map (fun (b, (tac, pp)) -> (tac, b, pp))
+               (e_my_find_search db_list local_db secvars hd gl)
   with Not_found -> []
 
 let find_first_goal gls =
@@ -210,7 +206,7 @@ type search_state = {
   dblist : hint_db list;
   localdb :  hint_db list;
   prev : prev_search_state;
-  local_lemmas : Evd.open_constr list;
+  local_lemmas : Tacexpr.delayed_open_constr list;
 }
 
 and prev_search_state = (* for info eauto *)
@@ -234,12 +230,12 @@ module SearchProblem = struct
       | [] -> []
       | (tac, cost, pptac) :: tacl ->
 	  try
-	    let lgls = apply_tac_list tac glls in
+	    let lgls = apply_tac_list (Proofview.V82.of_tactic tac) glls in
 (* 	    let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *)
 (* 	      msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *)
 	      (lgls, cost, pptac) :: aux tacl
-	  with e when Errors.noncritical e ->
-            let e = Errors.push e in
+	  with e when CErrors.noncritical e ->
+            let e = CErrors.push e in
             Refiner.catch_failerror e; aux tacl
     in aux l
 
@@ -262,9 +258,11 @@ module SearchProblem = struct
       let nbgl = List.length (sig_it lg) in
       assert (nbgl > 0);
       let g = find_first_goal lg in
+      let hyps = pf_ids_of_hyps g in
+      let secvars = secvars_of_hyps (pf_hyps g) in
       let map_assum id = (e_give_exact (mkVar id), (-1), lazy (str "exact" ++ spc () ++ pr_id id)) in
       let assumption_tacs =
-        let tacs = List.map map_assum (pf_ids_of_hyps g) in
+        let tacs = List.map map_assum hyps in
         let l = filter_tactics s.tacres tacs in
 	List.map (fun (res, cost, pp) -> { depth = s.depth; priority = cost; tacres = res;
 				    last_tactic = pp; dblist = s.dblist;
@@ -272,7 +270,7 @@ module SearchProblem = struct
 				    prev = ps; local_lemmas = s.local_lemmas}) l
       in
       let intro_tac =
-        let l = filter_tactics s.tacres [Proofview.V82.of_tactic Tactics.intro, (-1), lazy (str "intro")] in
+        let l = filter_tactics s.tacres [Tactics.intro, (-1), lazy (str "intro")] in
 	List.map
 	  (fun (lgls, cost, pp) ->
 	     let g' = first_goal lgls in
@@ -289,7 +287,9 @@ module SearchProblem = struct
       in
       let rec_tacs =
 	let l =
-	  filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g))
+          let concl = Reductionops.nf_evar (project g)(pf_concl g) in
+	  filter_tactics s.tacres
+                         (e_possible_resolve s.dblist (List.hd s.localdb) secvars concl)
 	in
 	List.map
 	  (fun (lgls, cost, pp) ->
@@ -352,13 +352,13 @@ let mk_eauto_dbg d =
   else Off
 
 let pr_info_nop = function
-  | Info -> msg_debug (str "idtac.")
+  | Info -> Feedback.msg_info (str "idtac.")
   | _ -> ()
 
 let pr_dbg_header = function
   | Off -> ()
-  | Debug -> msg_debug (str "(* debug eauto : *)")
-  | Info -> msg_debug (str "(* info eauto : *)")
+  | Debug -> Feedback.msg_debug (str "(* debug eauto: *)")
+  | Info  -> Feedback.msg_info (str "(* info eauto: *)")
 
 let pr_info dbg s =
   if dbg != Info then ()
@@ -369,7 +369,7 @@ let pr_info dbg s =
 	| State sp ->
 	  let mindepth = loop sp in
 	  let indent = String.make (mindepth - sp.depth) ' ' in
-	  msg_debug (str indent ++ Lazy.force s.last_tactic ++ str ".");
+	  Feedback.msg_info (str indent ++ Lazy.force s.last_tactic ++ str ".");
 	  mindepth
     in
     ignore (loop s)
@@ -416,89 +416,20 @@ let eauto ?(debug=Off) np lems dbnames =
   tclTRY (e_search_auto debug np lems db_list)
 
 let full_eauto ?(debug=Off) n lems gl =
-  let dbnames = current_db_names () in
-  let dbnames =  String.Set.remove "v62" dbnames in
-  let db_list = List.map searchtable_map (String.Set.elements dbnames) in
+  let db_list = current_pure_db () in
   tclTRY (e_search_auto debug n lems db_list) gl
 
 let gen_eauto ?(debug=Off) np lems = function
-  | None -> full_eauto ~debug np lems
-  | Some l -> eauto ~debug np lems l
+  | None -> Proofview.V82.tactic (full_eauto ~debug np lems)
+  | Some l -> Proofview.V82.tactic (eauto ~debug np lems l)
 
 let make_depth = function
   | None -> !default_search_depth
-  | Some (ArgArg d) -> d
-  | _ -> error "eauto called with a non closed argument."
+  | Some d -> d
 
 let make_dimension n = function
   | None -> (true,make_depth n)
-  | Some (ArgArg d) -> (false,d)
-  | _ -> error "eauto called with a non closed argument."
-
-open Genarg
-
-(* Hint bases *)
-
-let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases
-
-ARGUMENT EXTEND hintbases
-  TYPED AS preident_list_opt
-  PRINTED BY pr_hintbases
-| [ "with" "*" ] -> [ None ]
-| [ "with" ne_preident_list(l) ] -> [ Some l ]
-| [ ] -> [ Some [] ]
-END
-
-let pr_constr_coma_sequence prc _ _ =
-  prlist_with_sep pr_comma (fun (_,c) -> prc c)
-
-ARGUMENT EXTEND constr_coma_sequence
-  TYPED AS open_constr_list
-  PRINTED BY pr_constr_coma_sequence
-| [ open_constr(c) "," constr_coma_sequence(l) ] -> [ c::l ]
-| [ open_constr(c) ] -> [ [c] ]
-END
-
-let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using (fun (_,c) -> prc c)
-
-ARGUMENT EXTEND auto_using
-  TYPED AS open_constr_list
-  PRINTED BY pr_auto_using
-| [ "using" constr_coma_sequence(l) ] -> [ l ]
-| [ ] -> [ [] ]
-END
-
-TACTIC EXTEND eauto
-| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
-    hintbases(db) ] ->
-    [ Proofview.V82.tactic (gen_eauto (make_dimension n p) lems db) ]
-END
-
-TACTIC EXTEND new_eauto
-| [ "new" "auto" int_or_var_opt(n) auto_using(lems)
-    hintbases(db) ] ->
-    [ match db with
-      | None -> new_full_auto (make_depth n) lems
-      | Some l -> new_auto (make_depth n) lems l ]
-END
-
-TACTIC EXTEND debug_eauto
-| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
-    hintbases(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) ] ->
-    [ 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) ] ->
-    [ Proofview.V82.tactic (gen_eauto (true, make_depth p) lems db) ]
-END
+  | Some d -> (false,d)
 
 let cons a l = a :: l
 
@@ -512,27 +443,26 @@ let autounfolds db occs cls gl =
     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
+  in Proofview.V82.of_tactic (unfold_option unfolds cls) gl
 
-let autounfold db cls gl =
+let autounfold db cls =
+  Proofview.V82.tactic begin fun gl ->
   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
+  end
 
-let autounfold_tac db cls gl =
+let autounfold_tac db cls =
+  Proofview.tclUNIT () >>= fun () ->
   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) clause(cl) ] -> [ Proofview.V82.tactic (autounfold_tac db cl) ]
-END
+  autounfold dbs cls
 
 let unfold_head env (ids, csts) c = 
   let rec aux c = 
@@ -567,7 +497,7 @@ let unfold_head env (ids, csts) c =
   in aux c
 
 let autounfold_one db cl =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let env = Proofview.Goal.env gl in
   let concl = Proofview.Goal.concl gl in
   let st =
@@ -586,91 +516,4 @@ let autounfold_one db cl =
       | Some hyp -> change_in_hyp None (make_change_arg 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 *)
-(* 	    (Id.Set.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db) *)
-(*       in unfold_option unfolds cl *)
-
-(*       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 -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cst)) csts *)
-(* 	  (Id.Set.fold (fun id -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cl) ids acc))) *)
-(*       (tclFAIL 0 (mt())) db *)
-      
-TACTIC EXTEND autounfold_one
-| [ "autounfold_one" hintbases(db) "in" hyp(id) ] ->
-    [ autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, InHyp)) ]
-| [ "autounfold_one" hintbases(db) ] ->
-    [ autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ]
-      END
-
-TACTIC EXTEND autounfoldify
-| [ "autounfoldify" constr(x) ] -> [
-  Proofview.V82.tactic (
-    let db = match kind_of_term x with
-      | Const (c,_) -> Label.to_string (con_label c)
-      | _ -> assert false
-    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)  ] -> [
-    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
-      Tacticals.New.tclZEROMSG msg
-    | Some t ->
-      let state = Hint_db.transparent_state t in
-      unify ~state x y
-  ]
-END
-
-
-TACTIC EXTEND convert_concl_no_check
-| ["convert_concl_no_check" constr(x) ] -> [ convert_concl_no_check x DEFAULTcast ]
-END
-
-let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom
-
-ARGUMENT EXTEND hints_path_atom
-  TYPED AS hints_path_atom
-  PRINTED BY pr_hints_path_atom
-| [ global_list(g) ] -> [ PathHints (List.map Nametab.global g) ]
-| [ "*" ] -> [ PathAny ]
-END
-
-let pr_hints_path prc prx pry c = Hints.pp_hints_path c
-
-ARGUMENT EXTEND hints_path
-  TYPED AS hints_path
-  PRINTED BY pr_hints_path
-| [ "(" hints_path(p) ")"  ] -> [ p ]
-| [ "!" hints_path(p)  ] -> [ PathStar p ]
-| [ "emp" ] -> [ PathEmpty ]
-| [ "eps" ] -> [ PathEpsilon ]
-| [ hints_path_atom(a) ] -> [ PathAtom a ]
-| [ hints_path(p) "|" hints_path(q) ] -> [ PathOr (p, q) ]
-| [ hints_path(p) ";" hints_path(q) ] -> [ PathSeq (p, q) ]
-END
-
-let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases
-
-ARGUMENT EXTEND opthints
-  TYPED AS preident_list_opt
-  PRINTED BY pr_hintbases
-| [ ":" ne_preident_list(l) ] -> [ Some l ]
-| [ ] -> [ None ]
-END
-
-VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF
-| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [
-  let entry = HintsCutEntry p in
-    Hints.add_hints (Locality.make_section_locality (Locality.LocalityFixme.consume ()))
-      (match dbnames with None -> ["core"] | Some l -> l) entry ]
-END
+  end }
diff --git a/tactics/eauto.mli b/tactics/eauto.mli
index 1bb15d6c..8812093d 100644
--- a/tactics/eauto.mli
+++ b/tactics/eauto.mli
@@ -8,31 +8,26 @@
 
 open Term
 open Proof_type
-open Evd
 open Hints
 
-val hintbases : hint_db_name list option Pcoq.Gram.entry
+val e_assumption : unit Proofview.tactic
 
-val wit_hintbases : hint_db_name list option Genarg.uniform_genarg_type
+val registered_e_assumption : unit Proofview.tactic
 
-val wit_auto_using :
-  (Tacexpr.open_constr_expr list,
-  Tacexpr.open_glob_constr list, Evd.open_constr list)
-    Genarg.genarg_type
+val e_give_exact : ?flags:Unification.unify_flags -> constr -> unit Proofview.tactic
 
+val prolog_tac : Tacexpr.delayed_open_constr list -> int -> unit Proofview.tactic
 
-val e_assumption : tactic
-
-val registered_e_assumption : tactic
-
-val e_give_exact : ?flags:Unification.unify_flags -> constr -> tactic
-
-val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> open_constr list ->
-  hint_db_name list option -> tactic
+val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> Tacexpr.delayed_open_constr list ->
+  hint_db_name list option -> unit Proofview.tactic
 
 val eauto_with_bases :
   ?debug:Tacexpr.debug ->
   bool * int ->
-  open_constr list -> hint_db list -> Proof_type.tactic
+  Tacexpr.delayed_open_constr list -> hint_db list -> Proof_type.tactic
+
+val autounfold : hint_db_name list -> Locus.clause -> unit Proofview.tactic
+val autounfold_tac : hint_db_name list option -> Locus.clause -> unit Proofview.tactic
+val autounfold_one : hint_db_name list -> Locus.hyp_location option -> unit Proofview.tactic
 
-val autounfold : hint_db_name list -> Locus.clause -> tactic
+val make_dimension : int option -> int option -> bool * int
diff --git a/tactics/elim.ml b/tactics/elim.ml
index 1c7e1f0d..f2b9eec4 100644
--- a/tactics/elim.ml
+++ b/tactics/elim.ml
@@ -16,31 +16,23 @@ open Tacmach.New
 open Tacticals.New
 open Tactics
 open Proofview.Notations
+open Context.Named.Declaration
 
+(* Supposed to be called without as clause *)
 let introElimAssumsThen tac ba =
-  let nassums =
-    List.fold_left
-      (fun acc b -> if b then acc+2 else acc+1)
-      0 ba.Tacticals.branchsign
-  in
-  let introElimAssums = tclDO nassums intro in
+  assert (ba.Tacticals.branchnames == []);
+  let introElimAssums = tclDO ba.Tacticals.nassums intro in
   (tclTHEN introElimAssums (elim_on_ba tac ba))
 
-let introCaseAssumsThen tac ba =
-  let case_thin_sign =
-    List.flatten
-      (List.map (function b -> if b then [false;true] else [false])
-	ba.Tacticals.branchsign)
-  in
-  let n1 = List.length case_thin_sign in
+(* Supposed to be called with a non-recursive scheme *)
+let introCaseAssumsThen with_evars tac ba =
+  let n1 = List.length ba.Tacticals.branchsign in
   let n2 = List.length ba.Tacticals.branchnames in
   let (l1,l2),l3 =
     if n1 < n2 then List.chop n1 ba.Tacticals.branchnames, []
-    else
-      (ba.Tacticals.branchnames, []),
-       if n1 > n2 then snd (List.chop n2 case_thin_sign) else [] in
+    else (ba.Tacticals.branchnames, []), List.make (n1-n2) false in
   let introCaseAssums =
-    tclTHEN (intro_patterns l1) (intros_clearing l3) in
+    tclTHEN (intro_patterns with_evars l1) (intros_clearing l3) in
   (tclTHEN introCaseAssums (case_on_ba (tac l2) ba))
 
 (* The following tactic Decompose repeatedly applies the
@@ -71,7 +63,7 @@ and general_decompose_aux recognizer id =
   elimHypThen
     (introElimAssumsThen
        (fun bas ->
-	  tclTHEN (Proofview.V82.tactic (clear [id]))
+	  tclTHEN (clear [id])
 	    (tclMAP (general_decompose_on_hyp recognizer)
                (ids_of_named_context bas.Tacticals.assums))))
     id
@@ -84,20 +76,20 @@ let tmphyp_name = Id.of_string "_TmpHyp"
 let up_to_delta = ref false (* true *)
 
 let general_decompose recognizer c =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
   let type_of = pf_unsafe_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 -> Proofview.V82.tactic (clear [id]))));
-       Proofview.V82.tactic (exact_no_check c) ]
-  end
+	      (fun id -> clear [id])));
+       exact_no_check c ]
+  end }
 
 let head_in indl t gl =
   let env = Proofview.Goal.env gl in
-  let sigma = Proofview.Goal.sigma gl in
+  let sigma = Tacmach.New.project gl in
   try
     let ity,_ =
       if !up_to_delta
@@ -107,10 +99,10 @@ let head_in indl t gl =
   with Not_found -> false
 
 let decompose_these c l =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { 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
+  end }
 
 let decompose_and c =
   general_decompose
@@ -138,7 +130,7 @@ let induction_trailer abs_i abs_j bargs =
     (tclDO (abs_j - abs_i) intro)
     (onLastHypId
        (fun id ->
-          Proofview.Goal.nf_enter begin fun gl ->
+          Proofview.Goal.nf_enter { enter = begin fun gl ->
 	  let idty = pf_unsafe_type_of gl (mkVar id) in
 	  let fvty = global_vars (pf_env gl) idty in
 	  let possible_bring_hyps =
@@ -146,7 +138,8 @@ let induction_trailer abs_i abs_j bargs =
           in
 	  let (hyps,_) =
             List.fold_left
-	      (fun (bring_ids,leave_ids) (cid,_,_ as d) ->
+	      (fun (bring_ids,leave_ids) d ->
+                 let cid = get_id d in
                  if not (List.mem cid leave_ids)
                  then (d::bring_ids,leave_ids)
                  else (bring_ids,cid::leave_ids))
@@ -154,15 +147,14 @@ let induction_trailer abs_i abs_j bargs =
 	  in
           let ids = List.rev (ids_of_named_context hyps) in
 	  (tclTHENLIST
-            [bring_hyps hyps; tclTRY (Proofview.V82.tactic (clear ids));
-	     simple_elimination (mkVar id)])
-          end
+            [revert ids; simple_elimination (mkVar id)])
+          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
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
+  let abs_i = depth_of_quantified_hypothesis true h1 gl in
+  let abs_j = 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
@@ -173,7 +165,7 @@ let double_ind h1 h2 =
        	(fun id ->
            elimination_then
              (introElimAssumsThen (induction_trailer abs_i abs_j)) (mkVar id))))
-  end
+  end }
 
 let h_double_induction = double_ind
 
diff --git a/tactics/elim.mli b/tactics/elim.mli
index a94f642a..ae9cf85f 100644
--- a/tactics/elim.mli
+++ b/tactics/elim.mli
@@ -13,7 +13,7 @@ open Misctypes
 
 (** Eliminations tactics. *)
 
-val introCaseAssumsThen :
+val introCaseAssumsThen : Tacexpr.evars_flag ->
   (Tacexpr.intro_patterns -> branch_assumptions -> unit Proofview.tactic) ->
     branch_args -> unit Proofview.tactic
 
diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml
index 4ff774b8..93073fdc 100644
--- a/tactics/elimschemes.ml
+++ b/tactics/elimschemes.ml
@@ -18,6 +18,7 @@ open Indrec
 open Declarations
 open Typeops
 open Ind_tables
+open Sigma.Notations
 
 (* Induction/recursion schemes *)
 
@@ -51,19 +52,21 @@ let optimize_non_type_induction_scheme kind dep sort _ ind =
     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_ctx ectx) (ind,u) dep sort in
+    let sigma = Evd.merge_universe_context sigma ectx in
+    let sigma, c = build_induction_scheme env sigma (ind,u) dep sort in
       (c, Evd.evar_universe_context sigma), Safe_typing.empty_private_constants
 
 let build_induction_scheme_in_type dep sort ind =
   let env = Global.env () in
+  let sigma = Evd.from_env 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_ctx ectx) (ind,u) dep sort in
+  let sigma = Evd.merge_universe_context sigma (Evd.evar_universe_context_of ctxset) in
+  let sigma, c = build_induction_scheme env sigma (ind,u) dep sort in
     c, Evd.evar_universe_context sigma
  
 let rect_scheme_kind_from_type =
@@ -94,6 +97,10 @@ 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)
 
+let rec_scheme_kind_from_type =
+  declare_individual_scheme_object "_rec_nodep" ~aux:"_rec_nodep_from_type"
+  (optimize_non_type_induction_scheme rect_scheme_kind_from_type false InSet)
+
 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)
@@ -102,10 +109,10 @@ let rec_dep_scheme_kind_from_type =
 
 let build_case_analysis_scheme_in_type dep sort ind =
   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 sigma = Sigma.Unsafe.of_evar_map (Evd.from_env env) in
+  let Sigma (indu, sigma, _) = Sigma.fresh_inductive_instance env sigma ind in
+  let Sigma (c, sigma, _) = build_case_analysis_scheme env sigma indu dep sort in
+    c, Evd.evar_universe_context (Sigma.to_evar_map sigma)
 
 let case_scheme_kind_from_type =
   declare_individual_scheme_object "_case_nodep"
diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli
index c3679705..77f927f2 100644
--- a/tactics/elimschemes.mli
+++ b/tactics/elimschemes.mli
@@ -13,9 +13,11 @@ open Ind_tables
 val rect_scheme_kind_from_prop : individual scheme_kind
 val ind_scheme_kind_from_prop : individual scheme_kind
 val rec_scheme_kind_from_prop : individual scheme_kind
+val rect_scheme_kind_from_type : individual scheme_kind
 val rect_dep_scheme_kind_from_type : individual scheme_kind
 val ind_scheme_kind_from_type : individual scheme_kind
 val ind_dep_scheme_kind_from_type : individual scheme_kind
+val rec_scheme_kind_from_type : individual scheme_kind
 val rec_dep_scheme_kind_from_type : individual scheme_kind
 
 
diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml
index 8ba8f7b6..b1d3290a 100644
--- a/tactics/eqdecide.ml
+++ b/tactics/eqdecide.ml
@@ -12,9 +12,6 @@
 (*                           by Eduardo Gimenez                        *)
 (************************************************************************)
 
-(*i camlp4deps: "grammar/grammar.cma" i*)
-
-open Errors
 open Util
 open Names
 open Namegen
@@ -24,7 +21,9 @@ open Tactics
 open Tacticals.New
 open Auto
 open Constr_matching
+open Misctypes
 open Hipattern
+open Pretyping
 open Tacmach.New
 open Coqlib
 
@@ -50,7 +49,6 @@ open Coqlib
    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 =
@@ -66,17 +64,22 @@ let choose_noteq eqonleft =
 
 let mkBranches c1 c2 =
   tclTHENLIST
-    [Proofview.V82.tactic (generalize [c2]);
+    [generalize [c2];
      Simple.elim c1;
      intros;
      onLastHyp Simple.case;
      clear_last;
      intros]
 
+let discrHyp id =
+  let c = { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } in
+  let tac c = Equality.discr_tac false (Some (None, Tacexpr.ElimOnConstr c)) in
+  Tacticals.New.tclDELAYEDWITHHOLES false c tac
+
 let solveNoteqBranch side =
   tclTHEN (choose_noteq side)
     (tclTHEN introf
-      (onLastHypId (fun id -> Extratactics.discrHyp id)))
+      (onLastHypId (fun id -> discrHyp id)))
 
 (* Constructs the type {c1=c2}+{~c1=c2} *)
 
@@ -116,16 +119,21 @@ let rec rewrite_and_clear hyps = match hyps with
 let eqCase tac =
   tclTHEN intro (onLastHypId tac)
 
+let injHyp id =
+  let c = { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } in
+  let tac c = Equality.injClause None false (Some (None, Tacexpr.ElimOnConstr c)) in
+  Tacticals.New.tclDELAYEDWITHHOLES false c tac
+
 let diseqCase hyps eqonleft =
   let diseq  = Id.of_string "diseq" in
   let absurd = Id.of_string "absurd" in
   (tclTHEN (intro_using diseq)
   (tclTHEN (choose_noteq eqonleft)
   (tclTHEN (rewrite_and_clear (List.rev hyps))
-  (tclTHEN  (Proofview.V82.tactic red_in_concl)
+  (tclTHEN  (red_in_concl)
   (tclTHEN  (intro_using absurd)
   (tclTHEN  (Simple.apply (mkVar diseq))
-  (tclTHEN  (Extratactics.injHyp absurd)
+  (tclTHEN  (injHyp absurd)
             (full_trivial []))))))))
 
 open Proofview.Notations
@@ -146,7 +154,7 @@ let rec solveArg hyps eqonleft op largs rargs = match largs, rargs with
     intros_reflexivity;
   ]
 | a1 :: largs, a2 :: rargs ->
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
   let rectype = pf_unsafe_type_of gl a1 in
   let decide = mkDecideEqGoal eqonleft op rectype a1 a2 in
   let tac hyp = solveArg (hyp :: hyps) eqonleft op largs rargs in
@@ -154,13 +162,13 @@ let rec solveArg hyps eqonleft op largs rargs = match largs, rargs with
     if eqonleft then [eqCase tac;diseqCase hyps eqonleft;default_auto]
     else [diseqCase hyps eqonleft;eqCase tac;default_auto] in
   (tclTHENS (elim_type decide) subtacs)
-  end
+  end }
 | _ -> invalid_arg "List.fold_right2"
 
 let solveEqBranch rectype =
   Proofview.tclORELSE
     begin
-      Proofview.Goal.enter begin fun gl ->
+      Proofview.Goal.enter { 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
@@ -169,7 +177,7 @@ let solveEqBranch rectype =
           let rargs   = getargs rhs
           and largs   = getargs lhs in
           solveArg [] eqonleft op largs rargs
-      end
+      end }
     end
     begin function (e, info) -> match e with
       | PatternMatchingFailure -> Tacticals.New.tclZEROMSG (Pp.str"Unexpected conclusion!")
@@ -185,7 +193,7 @@ let hd_app c = match kind_of_term c with
 let decideGralEquality =
   Proofview.tclORELSE
     begin
-      Proofview.Goal.enter begin fun gl ->
+      Proofview.Goal.enter { 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
@@ -196,7 +204,7 @@ let decideGralEquality =
           (tclTHEN
              (mkBranches c1 c2)
              (tclORELSE (solveNoteqBranch eqonleft) (solveEqBranch rectype)))
-      end
+      end }
     end
     begin function (e, info) -> match e with
       | PatternMatchingFailure ->
@@ -207,20 +215,20 @@ let decideGralEquality =
 let decideEqualityGoal = tclTHEN intros decideGralEquality
 
 let decideEquality rectype =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
   let decide = mkGenDecideEqGoal rectype gl in
   (tclTHENS (cut decide) [default_auto;decideEqualityGoal])
-  end
+  end }
 
 
 (* The tactic Compare *)
 
 let compare c1 c2 =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
   let rectype = pf_unsafe_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
+  end }
diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml
index c9764af1..1a45217a 100644
--- a/tactics/eqschemes.ml
+++ b/tactics/eqschemes.ml
@@ -44,12 +44,11 @@
    natural expectation of the user.
 *)
 
-open Errors
+open CErrors
 open Util
 open Names
 open Term
 open Vars
-open Context
 open Declarations
 open Environ
 open Inductive
@@ -58,6 +57,8 @@ open Namegen
 open Inductiveops
 open Ind_tables
 open Indrec
+open Sigma.Notations
+open Context.Rel.Declaration
 
 let hid = Id.of_string "H"
 let xid = Id.of_string "X"
@@ -70,8 +71,8 @@ let build_dependent_inductive ind (mib,mip) =
   let realargs,_ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in
   applist
     (mkIndU ind,
-       extended_rel_list mip.mind_nrealdecls mib.mind_params_ctxt
-       @ extended_rel_list 0 realargs)
+       Context.Rel.to_extended_list mip.mind_nrealdecls mib.mind_params_ctxt
+       @ Context.Rel.to_extended_list 0 realargs)
 
 let my_it_mkLambda_or_LetIn s c = it_mkLambda_or_LetIn c s
 let my_it_mkProd_or_LetIn s c = it_mkProd_or_LetIn c s
@@ -104,11 +105,11 @@ let get_sym_eq_data env (ind,u) =
     error "Not an inductive type with a single constructor.";
   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
+  if List.exists is_local_def 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 not (Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt)) then
+  if not (Int.equal (Context.Rel.length constrsign) (Context.Rel.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
   if mip.mind_nrealargs > mib.mind_nparams then
@@ -139,11 +140,11 @@ let get_non_sym_eq_data env (ind,u) =
     error "Not an inductive type with a single constructor.";
   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
+  if List.exists is_local_def 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 not (Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt)) then
+  if not (Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt)) then
     error "Constructor must have no arguments";
   let _,constrargs = List.chop mib.mind_nparams constrargs in
   let constrargs = List.map (Vars.subst_instance_constr u) constrargs in
@@ -169,11 +170,11 @@ let build_sym_scheme env ind =
   let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 =
     get_sym_eq_data env indu in
   let cstr n =
-    mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in
+    mkApp (mkConstructUi(indu,1),Context.Rel.to_extended_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 indu specif in
   let realsign_ind =
-    name_context env ((Name varH,None,applied_ind)::realsign) in
+    name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in
   let ci = make_case_info (Global.env()) ind RegularStyle in
   let c = 
   (my_it_mkLambda_or_LetIn paramsctxt
@@ -182,7 +183,7 @@ let build_sym_scheme env ind =
      my_it_mkLambda_or_LetIn_name
        (lift_rel_context (nrealargs+1) realsign_ind)
        (mkApp (mkIndU indu,Array.concat
-	  [extended_rel_vect (3*nrealargs+2) paramsctxt1;
+	  [Context.Rel.to_extended_vect (3*nrealargs+2) paramsctxt1;
 	   rel_vect 1 nrealargs;
 	   rel_vect (2*nrealargs+2) nrealargs])),
      mkRel 1 (* varH *),
@@ -223,16 +224,16 @@ let build_sym_involutive_scheme env ind =
     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 cstr n = mkApp (mkConstructUi (indu,1),Context.Rel.to_extended_vect n paramsctxt) in
   let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
   let applied_ind = build_dependent_inductive indu specif in
   let applied_ind_C =
     mkApp
       (mkIndU indu, Array.append
-         (extended_rel_vect (nrealargs+1) mib.mind_params_ctxt)
+         (Context.Rel.to_extended_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
+    name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in
   let ci = make_case_info (Global.env()) ind RegularStyle in
   let c = 
     (my_it_mkLambda_or_LetIn paramsctxt
@@ -243,15 +244,15 @@ let build_sym_involutive_scheme env ind =
 	       (mkApp (eq,[|
 	       mkApp
 	       (mkIndU indu, Array.concat
-	       [extended_rel_vect (3*nrealargs+2) paramsctxt1;
+	       [Context.Rel.to_extended_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;
+	       [Context.Rel.to_extended_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;
+		[Context.Rel.to_extended_vect (3*nrealargs+2) paramsctxt1;
 		 rel_vect (2*nrealargs+2) nrealargs;
 		 rel_vect 1 nrealargs;
 		 [|mkRel 1|]])|]]);
@@ -334,7 +335,7 @@ let build_l2r_rew_scheme dep env ind kind =
   let eq,eqrefl,ctx = get_coq_eq ctx in
   let cstr n p =
     mkApp (mkConstructUi(indu,1),
-      Array.concat [extended_rel_vect n paramsctxt1;
+      Array.concat [Context.Rel.to_extended_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
@@ -342,26 +343,26 @@ let build_l2r_rew_scheme dep env ind kind =
   let applied_ind = build_dependent_inductive indu specif in
   let applied_ind_P =
     mkApp (mkIndU indu, Array.concat
-       [extended_rel_vect (3*nrealargs) paramsctxt1;
+       [Context.Rel.to_extended_vect (3*nrealargs) paramsctxt1;
         rel_vect 0 nrealargs;
         rel_vect nrealargs nrealargs]) in
   let applied_ind_G =
     mkApp (mkIndU indu, Array.concat
-       [extended_rel_vect (3*nrealargs+3) paramsctxt1;
+       [Context.Rel.to_extended_vect (3*nrealargs+3) paramsctxt1;
         rel_vect (nrealargs+3) nrealargs;
         rel_vect 0 nrealargs]) in
   let realsign_P = lift_rel_context nrealargs realsign in
   let realsign_ind_P =
-    name_context env ((Name varH,None,applied_ind_P)::realsign_P) in
+    name_context env ((LocalAssum (Name varH,applied_ind_P))::realsign_P) in
   let realsign_ind_G =
-    name_context env ((Name varH,None,applied_ind_G)::
+    name_context env ((LocalAssum (Name varH,applied_ind_G))::
                       lift_rel_context (nrealargs+3) realsign) in
   let applied_sym_C n =
      mkApp(sym,
-       Array.append (extended_rel_vect n mip.mind_arity_ctxt) [|mkVar varH|]) in
+       Array.append (Context.Rel.to_extended_vect n mip.mind_arity_ctxt) [|mkVar varH|]) in
   let applied_sym_G =
      mkApp(sym,
-       Array.concat [extended_rel_vect (nrealargs*3+4) paramsctxt1;
+       Array.concat [Context.Rel.to_extended_vect (nrealargs*3+4) paramsctxt1;
                      rel_vect (nrealargs+4) nrealargs;
                      rel_vect 1 nrealargs;
 		     [|mkRel 1|]]) in
@@ -371,7 +372,7 @@ let build_l2r_rew_scheme dep env ind kind =
   let ci = make_case_info (Global.env()) ind 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)
+    mkApp (mkVar varP,Array.append (Context.Rel.to_extended_vect 1 realsign)
            (if dep then [|cstr (2*nrealargs+1) 1|] else [||])) in
   let applied_PG =
     mkApp (mkVar varP,Array.append (rel_vect 1 nrealargs)
@@ -381,11 +382,11 @@ let build_l2r_rew_scheme dep env ind kind =
            (if dep then [|mkRel 2|] else [||])) in
   let applied_sym_sym =
          mkApp (sym,Array.concat
-	   [extended_rel_vect (2*nrealargs+4) paramsctxt1;
+	   [Context.Rel.to_extended_vect (2*nrealargs+4) paramsctxt1;
             rel_vect 4 nrealargs;
             rel_vect (nrealargs+4) nrealargs;
             [|mkApp (sym,Array.concat
-	      [extended_rel_vect (2*nrealargs+4) paramsctxt1;
+	      [Context.Rel.to_extended_vect (2*nrealargs+4) paramsctxt1;
 	       rel_vect (nrealargs+4) nrealargs;
 	       rel_vect 4 nrealargs;
 	       [|mkRel 2|]])|]]) in
@@ -408,7 +409,7 @@ let build_l2r_rew_scheme dep env ind kind =
                    mkApp (eq,[|lift 4 applied_ind;applied_sym_sym;mkRel 1|]),
                    applied_PR)),
        mkApp (sym_involutive,
-         Array.append (extended_rel_vect 3 mip.mind_arity_ctxt) [|mkVar varH|]),
+         Array.append (Context.Rel.to_extended_vect 3 mip.mind_arity_ctxt) [|mkVar varH|]),
        [|main_body|])
    else
      main_body))))))
@@ -447,7 +448,7 @@ let build_l2r_forward_rew_scheme dep env ind kind =
     get_sym_eq_data env indu in
   let cstr n p =
     mkApp (mkConstructUi(indu,1),
-      Array.concat [extended_rel_vect n paramsctxt1;
+      Array.concat [Context.Rel.to_extended_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
@@ -455,19 +456,19 @@ let build_l2r_forward_rew_scheme dep env ind kind =
   let applied_ind = build_dependent_inductive indu specif in
   let applied_ind_P =
     mkApp (mkIndU indu, Array.concat
-       [extended_rel_vect (4*nrealargs+2) paramsctxt1;
+       [Context.Rel.to_extended_vect (4*nrealargs+2) paramsctxt1;
         rel_vect 0 nrealargs;
         rel_vect (nrealargs+1) nrealargs]) in
   let applied_ind_P' =
     mkApp (mkIndU indu, Array.concat
-       [extended_rel_vect (3*nrealargs+1) paramsctxt1;
+       [Context.Rel.to_extended_vect (3*nrealargs+1) paramsctxt1;
         rel_vect 0 nrealargs;
         rel_vect (2*nrealargs+1) nrealargs]) in
   let realsign_P n = lift_rel_context (nrealargs*n+n) realsign in
   let realsign_ind =
-    name_context env ((Name varH,None,applied_ind)::realsign) in
+    name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in
   let realsign_ind_P n aP =
-    name_context env ((Name varH,None,aP)::realsign_P n) in
+    name_context env ((LocalAssum (Name varH,aP))::realsign_P n) 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
@@ -538,14 +539,14 @@ let build_r2l_forward_rew_scheme dep env ind kind =
   let ((mib,mip as specif),constrargs,realsign,paramsctxt,nrealargs) =
     get_non_sym_eq_data env indu in
   let cstr n =
-    mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in
+    mkApp (mkConstructUi(indu,1),Context.Rel.to_extended_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 indu specif in
   let realsign_ind =
-    name_context env ((Name varH,None,applied_ind)::realsign) in
+    name_context env ((LocalAssum (Name varH,applied_ind))::realsign) 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
@@ -554,8 +555,8 @@ let build_r2l_forward_rew_scheme dep env ind kind =
     applist (mkVar varP,if dep then constrargs_cstr else constrargs) in
   let applied_PG =
     mkApp (mkVar varP,
-           if dep then extended_rel_vect 0 realsign_ind
-	   else extended_rel_vect 1 realsign) in
+           if dep then Context.Rel.to_extended_vect 0 realsign_ind
+	   else Context.Rel.to_extended_vect 1 realsign) in
   let c = 
   (my_it_mkLambda_or_LetIn paramsctxt
   (my_it_mkLambda_or_LetIn_name realsign_ind
@@ -599,12 +600,12 @@ let fix_r2l_forward_rew_scheme (c, ctx') =
   | 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)
-	    (mkLambda_or_LetIn (map_rel_declaration (lift 2) ind)
+        (mkLambda_or_LetIn (map_constr (liftn (-1) 1) p)
+	  (mkLambda_or_LetIn (map_constr (liftn (-1) 2) hp)
+	    (mkLambda_or_LetIn (map_constr (lift 2) ind)
 	      (Reductionops.whd_beta Evd.empty
 		(applist (c,
-	          extended_rel_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2]))))))
+	          Context.Rel.to_extended_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2]))))))
       in c', ctx'
   | _ -> anomaly (Pp.str "Ill-formed non-dependent left-to-right rewriting scheme")
 
@@ -630,9 +631,10 @@ let fix_r2l_forward_rew_scheme (c, ctx') =
 (**********************************************************************)
  
 let build_r2l_rew_scheme dep env ind 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 sigma = Sigma.Unsafe.of_evar_map (Evd.from_env env) in
+  let Sigma (indu, sigma, _) = Sigma.fresh_inductive_instance env sigma ind in
+  let Sigma (c, sigma, _) = build_case_analysis_scheme env sigma indu dep k in
+    c, Evd.evar_universe_context (Sigma.to_evar_map sigma)
 
 let build_l2r_rew_scheme = build_l2r_rew_scheme
 let build_l2r_forward_rew_scheme = build_l2r_forward_rew_scheme
@@ -736,13 +738,13 @@ let build_congr env (eq,refl,ctx) ind =
   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
+  if List.exists is_local_def realsign then
     error "Inductive equalities with local definitions in arity not supported.";
   let env_with_arity = push_rel_context arityctxt env in
-  let (_,_,ty) = lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity in
+  let ty = get_type (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 Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt) then
+  if Int.equal (Context.Rel.length constrsign) (Context.Rel.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
@@ -758,8 +760,8 @@ let build_congr env (eq,refl,ctx) ind =
      (mkNamedLambda varH
         (applist
            (mkIndU indu,
-	    extended_rel_list (mip.mind_nrealargs+2) paramsctxt @
-	    extended_rel_list 0 realsign))
+	    Context.Rel.to_extended_list (mip.mind_nrealargs+2) paramsctxt @
+	    Context.Rel.to_extended_list 0 realsign))
      (mkCase (ci,
        my_it_mkLambda_or_LetIn_name
 	 (lift_rel_context (mip.mind_nrealargs+3) realsign)
@@ -767,9 +769,9 @@ let build_congr env (eq,refl,ctx) ind =
            (Anonymous,
             applist
              (mkIndU indu,
-	        extended_rel_list (2*mip.mind_nrealdecls+3)
+	        Context.Rel.to_extended_list (2*mip.mind_nrealdecls+3)
 		  paramsctxt
-	        @ extended_rel_list 0 realsign),
+	        @ Context.Rel.to_extended_list 0 realsign),
             mkApp (eq,
 	      [|mkVar varB;
                 mkApp (mkVar varf, [|lift (2*mip.mind_nrealdecls+4) b|]);
diff --git a/tactics/equality.ml b/tactics/equality.ml
index ef1ec13b..bb3cbad9 100644
--- a/tactics/equality.ml
+++ b/tactics/equality.ml
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
@@ -40,8 +40,10 @@ open Eqschemes
 open Locus
 open Locusops
 open Misctypes
+open Sigma.Notations
 open Proofview.Notations
 open Unification
+open Context.Named.Declaration
 
 (* Options *)
 
@@ -70,14 +72,27 @@ let _ =
   declare_bool_option
     { optsync  = true;
       optdepr  = false;
-      optname  = "injection left-to-right pattern order";
+      optname  = "injection left-to-right pattern order and clear by default when with introduction pattern";
       optkey   = ["Injection";"L2R";"Pattern";"Order"];
       optread  = (fun () -> !injection_pattern_l2r_order) ;
       optwrite = (fun b -> injection_pattern_l2r_order := b) }
 
-(* Rewriting tactics *)
+let injection_in_context = ref false
 
-let clear ids = Proofview.V82.tactic (clear ids)
+let use_injection_in_context () =
+  !injection_in_context
+  && Flags.version_strictly_greater Flags.V8_5
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "injection in context";
+      optkey   = ["Structural";"Injection"];
+      optread  = (fun () -> !injection_in_context) ;
+      optwrite = (fun b -> injection_in_context := b) }
+
+(* Rewriting tactics *)
 
 let tclNOTSAMEGOAL tac =
   Proofview.V82.tactic (Tacticals.tclNOTSAMEGOAL (Proofview.V82.of_tactic tac))
@@ -158,7 +173,7 @@ let instantiate_lemma_all frzevars gl c ty l l2r concl =
   let try_occ (evd', c') =
     Clenvtac.clenv_pose_dependent_evars true {eqclause with evd = evd'}
   in
-  let flags = make_flags frzevars (Proofview.Goal.sigma gl) rewrite_unif_flags eqclause in
+  let flags = make_flags frzevars (Tacmach.New.project gl) rewrite_unif_flags eqclause in
   let occs =
     w_unify_to_subterm_all ~flags env eqclause.evd
       ((if l2r then c1 else c2),concl)
@@ -229,7 +244,7 @@ let rewrite_keyed_core_unif_flags = {
 
   restrict_conv_on_strict_subterms = false;
   modulo_betaiota = true;
-  (* Different from conv_closed *)
+
   modulo_eta = true;
 }
 
@@ -242,12 +257,12 @@ let rewrite_keyed_unif_flags = {
 }
 
 let rewrite_elim with_evars frzevars cls c e =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
   let flags = if Unification.is_keyed_unification ()
 	      then rewrite_keyed_unif_flags else rewrite_conv_closed_unif_flags in
-  let flags = make_flags frzevars (Proofview.Goal.sigma gl) flags c in
+  let flags = make_flags frzevars (Tacmach.New.project gl) flags c in
   general_elim_clause with_evars flags cls c e
-  end
+  end }
 
 (* Ad hoc asymmetric general_elim_clause *)
 let general_elim_clause with_evars frzevars cls rew elim =
@@ -282,7 +297,7 @@ let general_elim_clause with_evars frzevars tac cls c t l l2r elim =
          (general_elim_clause with_evars frzevars cls c elim))
       tac
   in
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { 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
@@ -294,7 +309,7 @@ let general_elim_clause with_evars frzevars tac cls c t l l2r elim =
     let cs = instantiate_lemma typ in
     if firstonly then tclFIRST (List.map try_clause cs)
     else tclMAP try_clause cs
-  end
+  end }
 
 (* The next function decides in particular whether to try a regular
   rewrite or a generalized rewrite.
@@ -313,7 +328,7 @@ let jmeq_same_dom gl = function
     let rels, t = decompose_prod_assum t in
     let env = Environ.push_rel_context rels (Proofview.Goal.env gl) in
     match decompose_app t with
-      | _, [dom1; _; dom2;_] -> is_conv env (Proofview.Goal.sigma gl) dom1 dom2
+      | _, [dom1; _; dom2;_] -> is_conv env (Tacmach.New.project gl) dom1 dom2
       | _ -> false
 
 (* find_elim determines which elimination principle is necessary to
@@ -354,8 +369,8 @@ let find_elim hdcncl lft2rgt dep cls ot gl =
 	     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, Safe_typing.empty_private_constants
+      let Sigma (elim, sigma, p) = Sigma.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in
+      Sigma ((elim, Safe_typing.empty_private_constants), sigma, p)
   else
   let scheme_name = match dep, lft2rgt, inccl with
     (* Non dependent case *)
@@ -373,10 +388,10 @@ let find_elim hdcncl lft2rgt dep cls ot gl =
   | 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)
+      let Sigma (elim, sigma, p) =
+	Sigma.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c)
       in
-	sigma, elim, eff
+      Sigma ((elim, eff), sigma, p)
   | _ -> assert false
 
 let type_of_clause cls gl = match cls with
@@ -384,17 +399,21 @@ let type_of_clause cls gl = match cls with
   | Some id -> pf_get_hyp_typ id gl
 
 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
+  Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
+  let evd = Sigma.to_evar_map (Proofview.Goal.sigma gl) in
+  let isatomic = isProd (whd_zeta evd hdcncl) in
   let dep_fun = if isatomic then dependent else dependent_no_evar in
   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 <*>
+  let Sigma ((elim, effs), sigma, p) = find_elim hdcncl lft2rgt dep cls (Some t) gl in
+  let tac =
+      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
+  in
+  Sigma (tac, sigma, p)
+  end }
 
 let adjust_rewriting_direction args lft2rgt =
   match args with
@@ -417,8 +436,8 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac
   if occs != AllOccurrences then (
     rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac)
   else
-    Proofview.Goal.enter begin fun gl ->
-      let sigma = Proofview.Goal.sigma gl in
+    Proofview.Goal.enter { enter = begin fun gl ->
+      let sigma = Tacmach.New.project 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
@@ -445,7 +464,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac
 	            | None -> Proofview.tclZERO ~info e
             (* error "The provided term does not end with an equality or a declared rewrite relation." *)  
             end
-    end
+    end }
 
 let general_rewrite_ebindings =
   general_rewrite_ebindings_clause None
@@ -507,9 +526,9 @@ let general_rewrite_clause l2r with_evars ?tac c cl =
             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 ->
+          Proofview.Goal.enter { enter = begin fun gl ->
             do_hyps_atleastonce (ids gl)
-          end
+          end }
 	in
 	if cl.concl_occs == NoOccurrences then do_hyps else
 	  tclIFTHENTRYELSEMUST
@@ -517,25 +536,25 @@ let general_rewrite_clause l2r with_evars ?tac c cl =
 	   do_hyps
 
 let apply_special_clear_request clear_flag f =
-  Proofview.Goal.enter begin fun gl ->
-    let sigma = Proofview.Goal.sigma gl in
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let sigma = Tacmach.New.project gl in
     let env = Proofview.Goal.env gl in
     try
-      let sigma,(c,bl) = f env sigma in
+      let ((c, bl), sigma) = run_delayed env sigma f in
       apply_clear_request clear_flag (use_clear_hyp_by_default ()) c
     with
       e when catchable_exception e -> tclIDTAC
-  end
+  end }
 
 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
+    Proofview.Goal.enter { enter = begin fun gl ->
+      let sigma = Tacmach.New.project gl in
       let env = Proofview.Goal.env gl in
-      let sigma,c = f env sigma in
+      let (c, sigma) = run_delayed env sigma f in
       tclWITHHOLES with_evars
         (general_rewrite_clause l2r with_evars ?tac c cl) sigma
-    end
+    end }
   in
   let rec doN l2r c = function
     | Precisely n when n <= 0 -> Proofview.tclUNIT ()
@@ -598,19 +617,19 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt =
       | None -> Proofview.tclUNIT ()
       | Some tac ->  tclCOMPLETE tac
   in
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { 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)
+    if unsafe then Some (Tacmach.New.project gl)
     else
-      try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Proofview.Goal.sigma gl))
+      try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Tacmach.New.project gl))
       with Evarconv.UnableToUnify _ -> None
   in
   match evd with
   | None ->
-    tclFAIL 0 (str"Terms do not have convertible types.")
+    tclFAIL 0 (str"Terms do not have convertible types")
   | Some evd ->
     let e = build_coq_eq () in
     let sym = build_coq_eq_sym () in
@@ -624,7 +643,7 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt =
           tclTHEN (apply sym) assumption;
           try_prove_eq
          ])))
-  end
+  end }
 
 let replace c1 c2 =
   replace_using_leibniz onConcl c2 c1 false false None
@@ -682,16 +701,16 @@ let replace_in_clause_maybe_by c1 c2 cl tac_opt =
 exception DiscrFound of
   (constructor * int) list * constructor * constructor
 
-let injection_on_proofs = ref false
+let keep_proof_equalities_for_injection = 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) }
+      optkey   = ["Keep";"Proof";"Equalities"];
+      optread  = (fun () -> !keep_proof_equalities_for_injection) ;
+      optwrite = (fun b -> keep_proof_equalities_for_injection := b) }
 
 
 let find_positions env sigma t1 t2 =
@@ -702,8 +721,8 @@ let find_positions env sigma t1 t2 =
     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
+    let hd1,args1 = whd_all_stack env sigma t1 in
+    let hd2,args2 = whd_all_stack env sigma t2 in
     match (kind_of_term hd1, kind_of_term hd2) with
       | Construct (sp1,_), Construct (sp2,_)
           when Int.equal (List.length args1) (constructor_nallargs_env env sp1)
@@ -736,7 +755,7 @@ let find_positions env sigma t1 t2 =
 	    project env sorts posn t1_0 t2_0
   in
   try
-    let sorts = if !injection_on_proofs then [InSet;InType;InProp]
+    let sorts = if !keep_proof_equalities_for_injection then [InSet;InType;InProp]
 		else [InSet;InType]
     in
     Inr (findrec sorts [] t1 t2)
@@ -841,7 +860,7 @@ let descend_then env sigma head dirn =
         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, head, Array.of_list brl)))
+      Inductiveops.make_case_or_project env indf ci p head (Array.of_list brl)))
 
 (* Now we need to construct the discriminator, given a discriminable
    position.  This boils down to:
@@ -856,13 +875,13 @@ let descend_then env sigma head dirn =
 
  *)
 
-(* [construct_discriminator env dirn headval]
-   constructs a case-split on [headval], with the [dirn]-th branch
-   giving [True], and all the rest giving False. *)
+(* [construct_discriminator env sigma dirn c ind special default]]
+   constructs a case-split on [c] of type [ind], with the [dirn]-th
+   branch giving [special], and all the rest giving [default]. *)
 
-let construct_discriminator env sigma dirn c sort =
+let build_selector env sigma dirn c ind special default =
   let IndType(indf,_) =
-    try find_rectype env sigma (get_type_of env sigma c)
+    try find_rectype env sigma ind
     with Not_found ->
        (* one can find Rel(k) in case of dependent constructors
           like T := c : (A:Set)A->T and a discrimination
@@ -874,25 +893,29 @@ let construct_discriminator env sigma dirn c sort =
 		 dependent types.") in
   let (indp,_) = dest_ind_family indf in
   let ind, _ = check_privacy env indp in
+  let typ = Retyping.get_type_of env sigma default 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 p = it_mkLambda_or_LetIn typ deparsign in
   let cstrs = get_constructors env indf in
   let build_branch i =
-    let endpt = if Int.equal i dirn then true_0 else false_0 in
+    let endpt = if Int.equal i dirn then special else default in
     it_mkLambda_or_LetIn endpt cstrs.(i-1).cs_args in
   let brl =
     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 env sigma dirn c sort = function
-  | [] -> construct_discriminator env sigma dirn c sort
+let rec build_discriminator env sigma dirn c = function
+  | [] ->
+      let ind = get_type_of env sigma c in
+      let true_0,false_0 =
+        build_coq_True(),build_coq_False() in
+      build_selector env sigma dirn c ind true_0 false_0
   | ((sp,cnum),argnum)::l ->
       let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in
       let newc = mkRel(cnum_nlams-argnum) in
-      let subval = build_discriminator cnum_env sigma dirn newc sort l  in
+      let subval = build_discriminator cnum_env sigma dirn newc l in
       kont subval (build_coq_False (),mkSort (Prop Null))
 
 (* Note: discrimination could be more clever: if some elimination is
@@ -907,7 +930,7 @@ let rec build_discriminator env sigma dirn c sort = function
 *)
 
 let gen_absurdity id =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { 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
@@ -915,7 +938,7 @@ let gen_absurdity id =
     simplest_elim (mkVar id)
   else
     tclZEROMSG (str "Not the negation of an equality.")
-  end
+  end }
 
 (* Precondition: eq is leibniz equality
 
@@ -954,11 +977,11 @@ let apply_on_clause (f,t) clause =
      | _  -> errorlabstrm "" (str "Ill-formed clause applicator.")) in
   clenv_fchain ~with_univs:false argmv f_clause clause
 
-let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn sort =
+let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn =
   let e = next_ident_away eq_baseid (ids_of_context env) in
-  let e_env = push_named (e,None,t) env in
+  let e_env = push_named (Context.Named.Declaration.LocalAssum (e,t)) env in
   let discriminator =
-    build_discriminator e_env sigma dirn (mkVar e) sort cpath in
+    build_discriminator e_env sigma dirn (mkVar e) 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
@@ -967,23 +990,21 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn sort =
   Proofview.Unsafe.tclEVARS sigma <*>
   Proofview.tclEFFECTS eff <*>
   tclTHENS (assert_after Anonymous absurd_term)
-    [onLastHypId gen_absurdity; (Proofview.V82.tactic (refine pf))]
+    [onLastHypId gen_absurdity; (Proofview.V82.tactic (Tacmach.refine pf))]
 
 let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause =
   let sigma = eq_clause.evd in
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { 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 _ ->
 	tclZEROMSG (str"Not a discriminable equality.")
     | Inl (cpath, (_,dirn), _) ->
-	let sort = pf_apply get_type_of gl concl in
-	discr_positions env sigma u eq_clause cpath dirn sort
-  end
+	discr_positions env sigma u eq_clause cpath dirn
+  end }
 
 let onEquality with_evars tac (c,lbindc) =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let type_of = pf_unsafe_type_of gl in
   let reduce_to_quantified_ind = pf_apply Tacred.reduce_to_quantified_ind gl in
   let t = type_of c in
@@ -995,11 +1016,11 @@ let onEquality with_evars tac (c,lbindc) =
   tclTHEN
     (Proofview.Unsafe.tclEVARS eq_clause'.evd)
     (tac (eq,eqn,eq_args) eq_clause')
-  end
+  end }
 
 let onNegatedEquality with_evars tac =
-  Proofview.Goal.nf_enter begin fun gl ->
-    let sigma = Proofview.Goal.sigma gl in
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
+    let sigma = Tacmach.New.project 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
@@ -1009,7 +1030,7 @@ let onNegatedEquality with_evars tac =
             onEquality with_evars tac (mkVar id,NoBindings)))
     | _ ->
         tclZEROMSG (str "Not a negated primitive equality.")
-  end
+  end }
 
 let discrSimpleClause with_evars = function
   | None -> onNegatedEquality with_evars discrEq
@@ -1060,7 +1081,7 @@ let make_tuple env sigma (rterm,rty) lind =
   assert (dependent (mkRel lind) rty);
   let sigdata = find_sigma_data env (get_sort_of env sigma rty) in
   let sigma, a = type_of ~refresh:true env sigma (mkRel lind) in
-  let (na,_,_) = lookup_rel lind env in
+  let na = Context.Rel.Declaration.get_name (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) *)
@@ -1135,14 +1156,15 @@ let minimal_free_rels_rec env sigma =
 
 let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
   let sigdata = find_sigma_data env sort_of_ty in
-  let evdref = ref (Evd.create_goal_evar_defs sigma) in
+  let evdref = ref (Evd.clear_metas sigma) in
   let rec sigrec_clausal_form siglen p_i =
     if Int.equal siglen 0 then
       (* is the default value typable with the expected type *)
       let dflt_typ = unsafe_type_of env sigma dflt in
       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
+	let () =
+          evdref := Evarconv.solve_unif_constraints_with_heuristics env !evdref in
 	dflt
       with Evarconv.UnableToUnify _ ->
 	error "Cannot solve a unification problem."
@@ -1263,7 +1285,7 @@ let build_injector env sigma dflt c cpath =
 
 (*
 let try_delta_expand env sigma t =
-  let whdt = whd_betadeltaiota env sigma t  in
+  let whdt = whd_all env sigma t  in
   let rec hd_rec c  =
     match kind_of_term c with
       | Construct _ -> whdt
@@ -1278,7 +1300,7 @@ 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 inject_if_homogenous_dependent_pair ty =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { 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 *)
@@ -1311,12 +1333,12 @@ let inject_if_homogenous_dependent_pair ty =
        onLastHyp (fun hyp ->
         tclTHENS (cut (mkApp (ceq,new_eq_args)))
           [clear [destVar hyp];
-           Proofview.V82.tactic (refine
+           Proofview.V82.tactic (Tacmach.refine
              (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|])))
           ])]
   with Exit ->
     Proofview.tclUNIT ()
-  end
+  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
@@ -1331,7 +1353,7 @@ let simplify_args env sigma t =
 
 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 e_env = push_named (LocalAssum (e,t)) env in
   let evdref = ref sigma in
   let filter (cpath, t1', t2') =
     try
@@ -1353,13 +1375,13 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac =
     tclZEROMSG (str "Failed to decompose the equality.")
   else
     Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref)
-    (Proofview.tclBIND
-      (Proofview.Monad.List.map
+    (Tacticals.New.tclTHENFIRST
+      (Proofview.tclIGNORE (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)))
+            Proofview.V82.tactic (Tacmach.refine pf)])
+         (if l2r then List.rev injectors else injectors)))
+      (tac (List.length injectors)))
 
 let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause =
   let sigma = eq_clause.evd in
@@ -1368,7 +1390,10 @@ let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause =
   | Inl _ ->
      tclZEROMSG (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
+     let suggestion =
+         if !keep_proof_equalities_for_injection then
+            "" else
+            " You can try to use option Set Keep Proof Equalities." in
      tclZEROMSG (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 ->
      tclZEROMSG (str"Nothing to inject.")
@@ -1376,51 +1401,68 @@ let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause =
       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
+let get_previous_hyp_position id gl =
+  let rec aux dest = function
+  | [] -> raise (RefinerError (NoSuchHyp id))
+  | d :: right ->
+    let hyp = Context.Named.Declaration.get_id d in
+    if Id.equal hyp id then dest else aux (MoveAfter hyp) right
   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)
+  aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl))
+
+let injEq ?(old=false) with_evars clear_flag ipats =
+  (* Decide which compatibility mode to use *)
+  let ipats_style, l2r, dft_clear_flag, bounded_intro = match ipats with
+    | None when not old && use_injection_in_context () ->
+      Some [], true, true, true
+    | None -> None, false, false, false
+    | _ -> let b = use_injection_pattern_l2r_order () in ipats, b, b, b in
+  (* Built the post tactic depending on compatibility mode *)
+  let post_tac c n =
+    match ipats_style with
+    | Some ipats ->
+      Proofview.Goal.enter { enter = begin fun gl ->
+        let destopt = match kind_of_term c with
+        | Var id -> get_previous_hyp_position id gl
+        | _ -> MoveLast in
+        let clear_tac =
+          tclTRY (apply_clear_request clear_flag dft_clear_flag c) in
+        (* Try should be removal if dependency were treated *)
+        let intro_tac =
+          if bounded_intro
+          then intro_patterns_bound_to with_evars n destopt ipats
+          else intro_patterns_to with_evars destopt ipats in
+        tclTHEN clear_tac intro_tac
+      end }
+    | None -> tclIDTAC in
+  injEqThen post_tac l2r
+
+let inj ipats with_evars clear_flag = onEquality with_evars (injEq with_evars clear_flag ipats)
 
 let injClause ipats with_evars = function
-  | None -> onNegatedEquality with_evars (injEq None ipats)
+  | None -> onNegatedEquality with_evars (injEq with_evars None ipats)
   | Some c -> onInductionArg (inj ipats with_evars) c
 
+let simpleInjClause with_evars = function
+  | None -> onNegatedEquality with_evars (injEq ~old:true with_evars None None)
+  | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (injEq ~old:true with_evars clear_flag None)) c
+
 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
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
     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
+	  discr_positions env sigma u clause cpath dirn
       | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *)
         ntac (clenv_value clause) 0
     | Inr posns ->
 	inject_at_positions env sigma true u clause posns
           (ntac (clenv_value clause))
-  end
+  end }
 
 let dEqThen with_evars ntac = function
   | None -> onNegatedEquality with_evars (decompEqThen (ntac None))
@@ -1430,13 +1472,13 @@ 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 intro_decomp_eq tac data cl =
+  Proofview.Goal.enter { enter = begin fun gl ->
     let cl = pf_apply make_clenv_binding gl cl NoBindings in
     decompEqThen (fun _ -> tac) data cl
-  end
+  end }
 
-let _ = declare_intro_decomp_eq intro_decompe_eq
+let _ = declare_intro_decomp_eq intro_decomp_eq
 
 (* [subst_tuple_term dep_pair B]
 
@@ -1485,6 +1527,7 @@ let decomp_tuple_term env c t =
   in decomprec (mkRel 1) c t
 
 let subst_tuple_term env sigma dep_pair1 dep_pair2 b =
+  let sigma = Sigma.to_evar_map sigma in
   let typ = get_type_of env sigma dep_pair1 in
   (* We find all possible decompositions *)
   let decomps1 = decomp_tuple_term env dep_pair1 typ in
@@ -1509,7 +1552,7 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b =
   (* Retype to get universes right *)
   let sigma, expected_goal_ty = Typing.type_of env sigma expected_goal in
   let sigma, _ = Typing.type_of env sigma body in
-    sigma,body,expected_goal
+  Sigma.Unsafe.of_pair ((body, expected_goal), sigma)
 
 (* Like "replace" but decompose dependent equalities                      *)
 (* i.e. if equality is "exists t v = exists u w", and goal is "phi(t,u)", *)
@@ -1517,34 +1560,42 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b =
 (* on for further iterated sigma-tuples                                   *)
 
 let cutSubstInConcl l2r eqn =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
   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
+  let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in
+  let tac =
   tclTHENFIRST
     (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
+  in
+  Sigma (tac, sigma, p)
+  end }
 
 let cutSubstInHyp l2r eqn id =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
   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
+  let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in
+  let tac =
+    tclTHENFIRST
     (tclTHENLIST [
-       (Proofview.Unsafe.tclEVARS sigma);
        (change_in_hyp None (make_change_arg typ) (id,InHypTypeOnly));
        (replace_core (onHyp id) l2r eqn)
     ])
     (change_in_hyp None (make_change_arg expected) (id,InHypTypeOnly))
-  end
+  in
+  Sigma (tac, sigma, p)
+  end }
 
 let try_rewrite tac =
   Proofview.tclORELSE tac begin function (e, info) -> match e with
@@ -1566,11 +1617,11 @@ let cutRewriteInHyp l2r eqn id = cutRewriteClause l2r eqn (Some id)
 let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None
 
 let substClause l2r c cls =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
   let eq = pf_apply get_type_of gl c in
   tclTHENS (cutSubstClause l2r eq cls)
-    [Proofview.tclUNIT (); Proofview.V82.tactic (exact_no_check c)]
-  end
+    [Proofview.tclUNIT (); 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)
@@ -1595,25 +1646,16 @@ user = raise user error specific to rewrite
 (**********************************************************************)
 (* Substitutions tactics (JCF) *)
 
-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
-  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 regular_subst_tactic = ref true
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "more regular behavior of tactic subst";
+      optkey   = ["Regular";"Subst";"Tactic"];
+      optread  = (fun () -> !regular_subst_tactic);
+      optwrite = (:=) regular_subst_tactic }
 
 let restrict_to_eq_and_identity eq = (* compatibility *)
   if not (is_global glob_eq eq) &&
@@ -1623,12 +1665,17 @@ let restrict_to_eq_and_identity eq = (* compatibility *)
 exception FoundHyp of (Id.t * constr * bool)
 
 (* tests whether hyp [c] is [x = t] or [t = x], [x] not occurring in [t] *)
-let is_eq_x gl x (id,_,c) =
+let is_eq_x gl x d =
+  let id = get_id d in
   try
-    let c = pf_nf_evar gl c in
+    let is_var id c = match kind_of_term c with
+    | Var id' -> Id.equal id id'
+    | _ -> false
+    in
+    let c = pf_nf_evar gl (get_type d) 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))
+    if (is_var x lhs) && not (local_occur_var x rhs) then raise (FoundHyp (id,rhs,true));
+    if (is_var x rhs) && not (local_occur_var x lhs) then raise (FoundHyp (id,lhs,false))
   with Constr_matching.PatternMatchingFailure ->
     ()
 
@@ -1636,61 +1683,61 @@ let is_eq_x gl x (id,_,c) =
    erase hyp and x; proceed by generalizing all dep hyps *)
 
 let subst_one dep_proof_ok x (hyp,rhs,dir) =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
   let env = Proofview.Goal.env gl in
   let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in
   let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in
   (* The set of hypotheses using x *)
   let dephyps =
-    List.rev (snd (List.fold_right (fun (id,b,_ as dcl) (deps,allhyps) ->
+    List.rev (pi3 (List.fold_right (fun dcl (dest,deps,allhyps) ->
+      let id = get_id dcl in
       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)
+        let id_dest = if !regular_subst_tactic then dest else MoveLast in
+        (dest,id::deps,(id_dest,id)::allhyps)
       else
-        (deps,allhyps))
+        (MoveBefore id,deps,allhyps))
       hyps
-      ([x],[]))) in
+      (MoveBefore x,[x],[]))) in (* In practice, no dep hyps before x, so MoveBefore x is good enough *)
   (* Decides if x appears in conclusion *)
   let depconcl = occur_var env x concl in
   let need_rewrite = not (List.is_empty dephyps) || depconcl in
   tclTHENLIST
     ((if need_rewrite then
-      [revert dephyps;
+      [revert (List.map snd dephyps);
        general_rewrite dir AllOccurrences true dep_proof_ok (mkVar hyp);
-       (tclMAP intro_using dephyps)]
+       (tclMAP (fun (dest,id) -> intro_move (Some id) dest) dephyps)]
       else
        [Proofview.tclUNIT ()]) @
      [tclTRY (clear [x; hyp])])
-  end
+  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 =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
     let gl = Proofview.Goal.assume gl in
-    let (_,xval,_) = pf_get_hyp x gl in
+    let xval = pf_get_hyp x gl |> get_value 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;
+          let test hyp _ = is_eq_x gl x hyp in
+          Context.Named.fold_outside 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
+  end }
 
 let subst_gen dep_proof_ok ids =
-  tclTHEN Proofview.V82.nf_evar_goals (tclMAP (subst_one_var dep_proof_ok) ids)
+  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
@@ -1709,17 +1756,6 @@ let default_subst_tactic_flags () =
   else
     { only_leibniz = true; rewrite_dependent_proof = false }
 
-let regular_subst_tactic = ref false
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "more regular behavior of tactic subst";
-      optkey   = ["Regular";"Subst";"Tactic"];
-      optread  = (fun () -> !regular_subst_tactic);
-      optwrite = (:=) regular_subst_tactic }
-
 let subst_all ?(flags=default_subst_tactic_flags ()) () =
 
   if !regular_subst_tactic then
@@ -1729,51 +1765,54 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () =
     let gl = Proofview.Goal.assume gl in
     let env = Proofview.Goal.env gl in
     let find_eq_data_decompose = find_eq_data_decompose gl in
-    let test (hyp,_,c) =
+    let select_equation_name decl =
       try
-        let lbeq,u,(_,x,y) = find_eq_data_decompose c in
+        let lbeq,u,(_,x,y) = find_eq_data_decompose (get_type decl) in
         let eq = Universes.constr_of_global_univ (lbeq.eq,u) in
         if flags.only_leibniz then restrict_to_eq_and_identity eq;
         match kind_of_term x, kind_of_term y with
-        | Var z, _ | _, Var z when not (is_evaluable env (EvalVarRef z))  ->
-            Some hyp
+        | Var z, _  when not (is_evaluable env (EvalVarRef z)) ->
+            Some (get_id decl)
+        | _, Var z when not (is_evaluable env (EvalVarRef z)) ->
+            Some (get_id decl)
         | _ ->
             None
       with Constr_matching.PatternMatchingFailure -> None
     in
     let hyps = Proofview.Goal.hyps gl in
-    List.rev (List.map_filter test hyps)
+    List.rev (List.map_filter select_equation_name hyps)
   in
 
   (* Second step: treat equations *)
   let process hyp =
-    Proofview.Goal.enter begin fun gl ->
+    Proofview.Goal.enter { enter = begin fun gl ->
     let gl = Proofview.Goal.assume gl in
+    let env = Proofview.Goal.env gl in
     let find_eq_data_decompose = find_eq_data_decompose gl in
-    let (_,_,c) = pf_get_hyp hyp gl in
+    let c = pf_get_hyp hyp gl |> get_type in
     let _,_,(_,x,y) = find_eq_data_decompose c in
     (* J.F.: added to prevent failure on goal containing x=x as an hyp *)
     if Term.eq_constr x y then Proofview.tclUNIT () else
       match kind_of_term x, kind_of_term y with
-      | Var x', _ when not (occur_term x y) ->
+      | Var x', _ when not (occur_term x y) && not (is_evaluable env (EvalVarRef x')) ->
           subst_one flags.rewrite_dependent_proof x' (hyp,y,true)
-      | _, Var y' when not (occur_term y x) ->
+      | _, Var y' when not (occur_term y x) && not (is_evaluable env (EvalVarRef y')) ->
           subst_one flags.rewrite_dependent_proof y' (hyp,x,false)
       | _ ->
           Proofview.tclUNIT ()
-    end
+    end }
   in
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
     let ids = find_equations gl in
     tclMAP process ids
-  end
+  end }
 
   else
 
 (* Old implementation, not able to manage configurations like a=b, a=t,
    or situations like "a = S b, b = S a", or also accidentally unfolding
    let-ins *)
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let find_eq_data_decompose = find_eq_data_decompose gl in
   let test (_,c) =
     try
@@ -1790,7 +1829,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () =
   let ids = List.map_filter test hyps in
   let ids = List.uniquize ids in
   subst_gen flags.rewrite_dependent_proof ids
-  end
+  end }
 
 (* Rewrite the first assumption for which a condition holds
    and gives the direction of the rewrite *)
@@ -1818,18 +1857,20 @@ let cond_eq_term c t gl =
 let rewrite_assumption_cond cond_eq_term cl =
   let rec arec hyps gl = match hyps with
     | [] -> error "No such assumption."
-    | (id,_,t) ::rest ->
+    | hyp ::rest ->
+        let id = get_id hyp in
 	begin
 	  try
-            let dir = cond_eq_term t gl in
+            let dir = cond_eq_term (get_type hyp) gl in
 	    general_rewrite_clause dir false (mkVar id,NoBindings) cl
 	  with | Failure _ | UserError _ -> arec rest gl
 	end
   in
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
+    let gl = Proofview.Goal.lift gl Sigma.Unsafe.le in
     let hyps = Proofview.Goal.hyps gl in
     arec hyps gl
-  end
+  end }
 
 (* Generalize "subst x" to substitution of subterm appearing as an
    equation in the context, but not clearing the hypothesis *)
diff --git a/tactics/equality.mli b/tactics/equality.mli
index f84dafb3..47cb6b82 100644
--- a/tactics/equality.mli
+++ b/tactics/equality.mli
@@ -72,16 +72,18 @@ 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 -> unit Proofview.tactic
+  constr with_bindings destruction_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
+  constr with_bindings destruction_arg option -> unit Proofview.tactic
 val injHyp       : clear_flag -> Id.t -> unit Proofview.tactic
 val injConcl     : unit Proofview.tactic
+val simpleInjClause : evars_flag ->
+  constr with_bindings destruction_arg option -> unit Proofview.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 dEq : evars_flag -> constr with_bindings destruction_arg option -> unit Proofview.tactic
+val dEqThen : evars_flag -> (clear_flag -> constr -> int -> unit Proofview.tactic) -> constr with_bindings destruction_arg option -> unit Proofview.tactic
 
 val make_iterated_tuple :
   env -> evar_map -> constr -> (constr * types) -> evar_map * (constr * constr * constr)
@@ -117,3 +119,8 @@ val subst_all : ?flags:subst_tactic_flags -> unit -> unit Proofview.tactic
 val replace_term : bool option -> constr -> clause -> unit Proofview.tactic
 
 val set_eq_dec_scheme_kind : mutual scheme_kind -> unit
+
+(* [build_selector env sigma i c t u v] matches on [c] of
+   type [t] and returns [u] in branch [i] and [v] on other branches *)
+val build_selector : env -> evar_map -> int -> constr -> types ->
+  constr -> constr -> constr
diff --git a/tactics/geninterp.ml b/tactics/geninterp.ml
deleted file mode 100644
index 0ad3abb5..00000000
--- a/tactics/geninterp.ml
+++ /dev/null
@@ -1,38 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \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
deleted file mode 100644
index 7f25a022..00000000
--- a/tactics/geninterp.mli
+++ /dev/null
@@ -1,28 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \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/hightactics.mllib b/tactics/hightactics.mllib
deleted file mode 100644
index ff2e1ff6..00000000
--- a/tactics/hightactics.mllib
+++ /dev/null
@@ -1,11 +0,0 @@
-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
index 42e5067c..9a96b738 100644
--- a/tactics/hints.ml
+++ b/tactics/hints.ml
@@ -8,7 +8,7 @@
 
 open Pp
 open Util
-open Errors
+open CErrors
 open Names
 open Vars
 open Term
@@ -33,6 +33,8 @@ open Pfedit
 open Tacred
 open Printer
 open Vernacexpr
+open Sigma.Notations
+open Context.Named.Declaration
 
 (****************************************)
 (* General functions                    *)
@@ -64,6 +66,28 @@ let decompose_app_bound t =
     | Proj (p, c) -> ConstRef (Projection.constant p), Array.cons c args
     | _ -> raise Bound
 
+(** Compute the set of section variables that remain in the named context.
+    Starts from the top to the bottom of the context, stops at the first
+    different declaration between the named hyps and the section context. *)
+let secvars_of_hyps hyps =
+  let secctx = Global.named_context () in
+  let pred, all =
+    List.fold_left (fun (pred,all) decl ->
+        try let _ = Context.Named.lookup (get_id decl) hyps in
+          (* Approximation, it might be an hypothesis reintroduced with same name and unconvertible types,
+             we must allow it currently, as comparing the declarations for syntactic equality is too
+             strong a check (e.g. an unfold in a section variable would make it unusable). *)
+          (Id.Pred.add (get_id decl) pred, all)
+        with Not_found -> (pred, false))
+      (Id.Pred.empty,true) secctx
+  in
+  if all then Id.Pred.full (* If the whole section context is available *)
+  else pred
+
+let empty_hint_info =
+  let open Vernacexpr in
+  { hint_priority = None; hint_pattern = None }
+
 (************************************************************************)
 (*           The Type of Constructions Autotactic Hints                 *)
 (************************************************************************)
@@ -74,20 +98,27 @@ type 'a hint_ast =
   | 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 *)
+  | Extern     of Genarg.glob_generic_argument (* Hint Extern *)
 
-type hints_path_atom = 
-  | PathHints of global_reference list
+
+type 'a hints_path_atom_gen =
+  | PathHints of 'a list
+  (* For forward hints, their names is the list of projections *)
   | 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
+type hints_path_atom = global_reference hints_path_atom_gen
+
+type 'a hints_path_gen =
+  | PathAtom of 'a hints_path_atom_gen
+  | PathStar of 'a hints_path_gen
+  | PathSeq of 'a hints_path_gen * 'a hints_path_gen
+  | PathOr of 'a hints_path_gen * 'a hints_path_gen
   | PathEmpty
   | PathEpsilon
 
+type pre_hints_path = Libnames.reference hints_path_gen
+type hints_path = global_reference hints_path_gen
+
 type hint_term =
   | IsGlobRef of global_reference
   | IsConstr of constr * Univ.universe_context_set
@@ -102,11 +133,13 @@ type raw_hint = constr * types * Univ.universe_context_set
 type hint = (raw_hint * clausenv) hint_ast with_uid
 
 type 'a with_metadata = {
-  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;     (* the tactic to apply when the concl matches pat *)
+  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 *)
+  db : string option; (** The database from which the hint comes *)
+  secvars : Id.Pred.t; (* The set of section variables the hint depends on *)
+  code    : 'a;     (* the tactic to apply when the concl matches pat *)
 }
 
 type full_hint = hint with_metadata
@@ -153,27 +186,6 @@ let fresh_key =
     in
     KerName.make mp dir (Label.of_id lbl)
 
-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_hint_metadata 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
@@ -208,7 +220,7 @@ type search_entry = {
   sentry_nopat : stored_data list;
   sentry_pat : stored_data list;
   sentry_bnet : Bounded_net.t;
-  sentry_mode : bool array list;
+  sentry_mode : hint_mode array list;
 }
 
 let empty_se = {
@@ -336,6 +348,12 @@ let rec is_empty = function
   | PathEmpty -> true
   | PathEpsilon -> false
 
+let path_seq p p' =
+  match p, p' with
+  | PathEpsilon, p' -> p'
+  | p, PathEpsilon -> p
+  | p, p' -> PathSeq (p, p')
+                    
 let rec path_derivate hp hint =
   let rec derivate_atoms hints hints' =
     match hints, hints' with
@@ -343,26 +361,26 @@ let rec path_derivate hp hint =
     | [], [] -> PathEpsilon
     | [], hints -> PathEmpty
     | grs, [] -> PathAtom (PathHints grs)
-    | _, _ -> PathEmpty 
+    | _, _ -> 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
+  match hp with
+  | PathAtom PathAny -> PathEpsilon
+  | PathAtom (PathHints grs) -> 
+     (match grs, hint with
+      | h :: _, 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 (path_seq hpder hp', path_derivate hp' hint)
+     else if is_empty hpder then PathEmpty 
+     else path_seq 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
@@ -382,19 +400,40 @@ let rec normalize_path h =
 
 let path_derivate hp hint = normalize_path (path_derivate hp hint)
 
-let pp_hints_path_atom a =
+let pp_hints_path_atom prg a =
   match a with
-  | PathAny -> str"*"
-  | PathHints grs -> pr_sequence pr_global grs
-					   
-let rec pp_hints_path = function
-  | PathAtom pa -> pp_hints_path_atom pa
-  | 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 ")"
+  | PathAny -> str"_"
+  | PathHints grs -> pr_sequence prg grs
+
+let pp_hints_path_gen prg =
+  let rec aux = function
+    | PathAtom pa -> pp_hints_path_atom prg pa
+    | PathStar (PathAtom PathAny) -> str"_*"
+    | PathStar p -> str "(" ++ aux p ++ str")*"
+    | PathSeq (p, p') -> aux p ++ spc () ++ aux p'
+    | PathOr (p, p') -> 
+     str "(" ++ aux p ++ spc () ++ str"|" ++ cut () ++ spc () ++
+     aux p' ++ str ")"
   | PathEmpty -> str"emp"
   | PathEpsilon -> str"eps"
+  in aux
+     
+let pp_hints_path = pp_hints_path_gen pr_global
+
+let glob_hints_path_atom p =
+  match p with
+  | PathHints g -> PathHints (List.map Nametab.global g)
+  | PathAny -> PathAny
+
+let glob_hints_path =
+  let rec aux = function
+    | PathAtom pa -> PathAtom (glob_hints_path_atom pa)
+    | PathStar p -> PathStar (aux p)
+    | PathSeq (p, p') -> PathSeq (aux p, aux p')
+    | PathOr (p, p') -> PathOr (aux p, aux p')
+    | PathEmpty -> PathEmpty
+    | PathEpsilon -> PathEpsilon
+  in aux
 
 let subst_path_atom subst p =
   match p with
@@ -421,7 +460,38 @@ let rec subst_hints_path subst hp =
       if p' == p && q' == q then hp else PathOr (p', q')
   | _ -> hp
 
-module Hint_db = struct
+type hint_db_name = string
+
+module Hint_db :
+sig
+type t
+val empty : ?name:hint_db_name -> transparent_state -> bool -> t
+val find : global_reference -> t -> search_entry
+val map_none : secvars:Id.Pred.t -> t -> full_hint list
+val map_all : secvars:Id.Pred.t -> global_reference -> t -> full_hint list
+val map_existential : secvars:Id.Pred.t ->
+		      (global_reference * constr array) -> constr -> t -> full_hint list
+val map_eauto : secvars:Id.Pred.t ->
+		(global_reference * constr array) -> constr -> t -> full_hint list
+val map_auto : secvars:Id.Pred.t ->
+	       (global_reference * constr array) -> constr -> t -> full_hint list
+val add_one : env -> evar_map -> hint_entry -> t -> t
+val add_list : env -> evar_map -> 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 -> hint_mode array list -> full_hint 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 add_mode : global_reference -> hint_mode array -> t -> t
+val cut : t -> hints_path
+val unfolds : t -> Id.Set.t * Cset.t
+val fold : (global_reference option -> hint_mode array list -> full_hint list -> 'a -> 'a) ->
+  t -> 'a -> 'a
+
+end =
+struct
 
   type t = {
     hintdb_state : Names.transparent_state;
@@ -432,69 +502,83 @@ module Hint_db = struct
     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
+    hintdb_nopat : (global_reference option * stored_data) list;
+    hintdb_name : string option;
   }
 
   let next_hint_id db =
     let h = db.hintdb_max_id in
     { db with hintdb_max_id = succ db.hintdb_max_id }, h
 
-  let empty st use_dn = { hintdb_state = st;
+  let empty ?name 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 = [] }
+			  hintdb_nopat = [];
+			  hintdb_name = name; }
 
   let find key db =
     try Constr_map.find key db.hintdb_map
     with Not_found -> empty_se
  
-  let realize_tac (id,tac) = tac
-
+  let realize_tac secvars (id,tac) =
+    if Id.Pred.subset tac.secvars secvars then Some tac
+    else
+      (** Warn about no longer typable hint? *)
+      None
+
+  let match_mode m arg =
+    match m with
+    | ModeInput -> not (occur_existential arg)
+    | ModeNoHeadEvar ->
+       Evarutil.(try ignore(head_evar arg); false
+                 with NoHeadEvar -> true)
+    | ModeOutput -> true
+                               
   let matches_mode args mode =
-    Array.length args == Array.length mode &&
-      Array.for_all2 (fun arg m -> not (m && occur_existential arg)) args mode
+    Array.length mode == Array.length args &&
+      Array.for_all2 match_mode mode args
       
   let matches_modes args modes =
     if List.is_empty modes then true
     else List.exists (matches_mode args) modes
 
-  let merge_entry db nopat pat =
+  let merge_entry secvars db nopat pat =
     let h = List.sort pri_order_int (List.map snd db.hintdb_nopat) in
     let h = List.merge pri_order_int h nopat in
     let h = List.merge pri_order_int h pat in
-    List.map realize_tac h
+    List.map_filter (realize_tac secvars) h
 
-  let map_none db =
-    merge_entry db [] []
+  let map_none ~secvars db =
+    merge_entry secvars db [] []
 
-  let map_all k db =
+  let map_all ~secvars k db =
     let se = find k db in
-    merge_entry db se.sentry_nopat se.sentry_pat
+    merge_entry secvars db se.sentry_nopat se.sentry_pat
 	
   (** Precondition: concl has no existentials *)
-  let map_auto (k,args) concl db =
+  let map_auto ~secvars (k,args) concl db =
     let se = find k db in
     let st = if db.use_dn then  (Some db.hintdb_state) else None in
     let pat = lookup_tacs concl st se in
-    merge_entry db [] pat
+    merge_entry secvars db [] pat
 
-  let map_existential (k,args) concl db =
+  let map_existential ~secvars (k,args) concl db =
     let se = find k db in
       if matches_modes args se.sentry_mode then
-        merge_entry db se.sentry_nopat se.sentry_pat
-      else merge_entry db [] []
+        merge_entry secvars db se.sentry_nopat se.sentry_pat
+      else merge_entry secvars db [] []
 
   (* [c] contains an existential *)
-  let map_eauto (k,args) concl db =
+  let map_eauto ~secvars (k,args) concl db =
     let se = find k db in
       if matches_modes args se.sentry_mode then
         let st = if db.use_dn then Some db.hintdb_state else None in
         let pat = lookup_tacs concl st se in
-        merge_entry db [] pat
-      else merge_entry db [] []
+        merge_entry secvars db [] pat
+      else merge_entry secvars db [] []
 
   let is_exact = function
     | Give_exact _ -> true
@@ -505,7 +589,7 @@ module Hint_db = struct
     | _ -> false
 
   let addkv gr id v db =
-    let idv = id, v in
+    let idv = id, { v with db = db.hintdb_name } in
     let k = match gr with
       | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr &&
 	  is_unfold v.code.obj then None else Some gr
@@ -570,11 +654,11 @@ module Hint_db = struct
 
   let get_entry se =
     let h = List.merge pri_order_int se.sentry_nopat se.sentry_pat in
-    List.map realize_tac h
+    List.map snd h
 
   let iter f db =
     let iter_se k se = f (Some k) se.sentry_mode (get_entry se) in
-    f None [] (List.map (fun x -> realize_tac (snd x)) db.hintdb_nopat);
+    f None [] (List.map (fun x -> snd (snd x)) db.hintdb_nopat);
     Constr_map.iter iter_se db.hintdb_map
 
   let fold f db accu =
@@ -609,8 +693,6 @@ 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"
@@ -631,8 +713,7 @@ let searchtable_add (name,db) =
 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 current_pure_db () = List.map snd (current_db ())
 
 let error_no_such_hint_database x =
   errorlabstrm "Hints" (str "No such Hint database: " ++ str x ++ str ".")
@@ -672,7 +753,20 @@ let try_head_pattern c =
 
 let with_uid c = { obj = c; uid = fresh_key () }
 
-let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) =
+let secvars_of_idset s =
+  Id.Set.fold (fun id p ->
+      if is_section_variable id then
+        Id.Pred.add id p
+      else p) s Id.Pred.empty
+
+let secvars_of_constr env c =
+  secvars_of_idset (global_vars_set env c)
+
+let secvars_of_global env gr =
+  secvars_of_idset (vars_of_global_reference env gr)
+
+let make_exact_entry env sigma info poly ?(name=PathAny) (c, cty, ctx) =
+  let secvars = secvars_of_constr env c in
   let cty = strip_outer_cast cty in
     match kind_of_term cty with
     | Prod _ -> failwith "make_exact_entry"
@@ -682,14 +776,17 @@ let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) =
 	  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 = with_uid (Give_exact (c, cty, ctx)); })
+	let pri = match info.hint_priority with None -> 0 | Some p -> p in
+	let pat = match info.hint_pattern with
+	| Some pat -> snd pat
+	| None -> pat
+	in
+        (Some hd,
+	 { pri; poly; pat = Some pat; name;
+	   db = None; secvars;
+	   code = with_uid (Give_exact (c, cty, ctx)); })
 
-let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, cty, ctx) =
+let make_apply_entry env sigma (eapply,hnf,verbose) info 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 _ ->
@@ -701,23 +798,25 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c,
 	  try head_pattern_bound pat
           with BoundPattern -> failwith "make_apply_entry" in
         let nmiss = List.length (clenv_missing ce) in
+        let secvars = secvars_of_constr env c in
+	let pri = match info.hint_priority with None -> nb_hyp cty + nmiss | Some p -> p in
+	let pat = match info.hint_pattern with
+	| Some p -> snd p | None -> pat
+	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;
+          { pri; poly; pat = Some pat; name;
+            db = None;
+            secvars;
             code = with_uid (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 ++
+	    Feedback.msg_info (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;
+           { pri; poly; pat = Some pat; name;
+	     db = None; secvars;
              code = with_uid (ERes_pf(c,cty,ctx)); })
         end
     | _ -> failwith "make_apply_entry"
@@ -726,18 +825,56 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c,
    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 pr_hint_term env sigma ctx = function
+  | IsGlobRef gr -> pr_global gr
+  | IsConstr (c, ctx) ->
+     let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in
+     pr_constr_env env sigma c
+
+(** We need an object to record the side-effect of registering
+  global universes associated with a hint. *)
+let cache_context_set (_,c) =
+  Global.push_context_set false c
+
+let input_context_set : Univ.ContextSet.t -> Libobject.obj =
+  let open Libobject in
+    declare_object
+    { (default_object "Global universe context") with
+      cache_function = cache_context_set;
+      load_function = (fun _ -> cache_context_set);
+      discharge_function = (fun (_,a) -> Some a);
+      classify_function = (fun a -> Keep a) }
+
+let warn_polymorphic_hint =
+  CWarnings.create ~name:"polymorphic-hint" ~category:"automation"
+         (fun hint -> strbrk"Using polymorphic hint " ++ hint ++
+                        str" monomorphically" ++
+                        strbrk" use Polymorphic Hint to use it polymorphically.")
 
-let make_resolves env sigma flags pri poly ?name cr =
+let fresh_global_or_constr env sigma poly cr =
+  let isgr, (c, ctx) =
+    match cr with
+    | IsGlobRef gr ->
+       true, Universes.fresh_global_instance env gr
+    | IsConstr (c, ctx) -> false, (c, ctx)
+  in
+    if poly then (c, ctx)
+    else if Univ.ContextSet.is_empty ctx then (c, ctx)
+    else begin
+      if isgr then
+        warn_polymorphic_hint (pr_hint_term env sigma ctx cr);
+      Lib.add_anonymous_leaf (input_context_set ctx);
+      (c, Univ.ContextSet.empty)
+    end
+
+let make_resolves env sigma flags info 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]
+			     [make_exact_entry env sigma info poly ?name;
+			      make_apply_entry env sigma flags info poly ?name]
   in
   if List.is_empty ents then
     errorlabstrm "Hint"
@@ -747,16 +884,19 @@ let make_resolves env sigma flags pri poly ?name cr =
   ents
 
 (* used to add an hypothesis to the local hint database *)
-let make_resolve_hyp env sigma (hname,_,htyp) =
+let make_resolve_hyp env sigma decl =
+  let hname = get_id decl in
+  let c = mkVar hname in
   try
-    [make_apply_entry env sigma (true, true, false) None false
+    [make_apply_entry env sigma (true, true, false) empty_hint_info false
        ~name:(PathHints [VarRef hname])
-       (mkVar hname, htyp, Univ.ContextSet.empty)]
+       (c, get_type decl, 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,
@@ -764,15 +904,20 @@ let make_unfold eref =
      poly = false;
      pat = None;
      name = PathHints [g];
+     db = None;
+     secvars = secvars_of_global (Global.env ()) g;
      code = with_uid (Unfold_nth eref) })
 
 let make_extern pri pat tacast =
+  let tacast = Genarg.in_gen (Genarg.glbwit Constrarg.wit_ltac) tacast in
   let hdconstr = Option.map try_head_pattern pat in
   (hdconstr,
    { pri = pri;
      poly = false;
      pat = pat;
      name = PathAny;
+     db = None;
+     secvars = Id.Pred.empty; (* Approximation *)
      code = with_uid (Extern tacast) })  
 
 let make_mode ref m = 
@@ -796,6 +941,8 @@ let make_trivial env sigma poly ?(name=PathAny) r =
 	      poly = poly;
               pat = Some (Patternops.pattern_of_constr env ce.evd (clenv_type ce));
 	      name = name;
+              db = None;
+              secvars = secvars_of_constr env c;
               code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx)) })
 
 
@@ -809,7 +956,7 @@ let make_trivial env sigma poly ?(name=PathAny) r =
 
 let get_db dbname =
   try searchtable_map dbname
-  with Not_found -> Hint_db.empty empty_transparent_state false
+  with Not_found -> Hint_db.empty ~name:dbname empty_transparent_state false
 
 let add_hint dbname hintlist =
   let check (_, h) =
@@ -848,7 +995,7 @@ type hint_action =
   | AddHints of hint_entry list
   | RemoveHints of global_reference list
   | AddCut of hints_path
-  | AddMode of global_reference * bool array
+  | AddMode of global_reference * hint_mode array
 
 let add_cut dbname path =
   let db = get_db dbname in
@@ -869,7 +1016,7 @@ type hint_obj = {
 let load_autohint _ (kn, h) =
   let name = h.hint_name in
   match h.hint_action with
-  | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty st b)
+  | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty ~name st b)
   | AddTransparency (grs, b) -> add_transparency name grs b
   | AddHints hints -> add_hint name hints
   | RemoveHints grs -> remove_hint name grs
@@ -918,7 +1065,7 @@ let subst_autohint (subst, obj) =
           let ref' = subst_evaluable_reference subst ref in
           if ref==ref' then data.code.obj else Unfold_nth ref'
       | Extern tac ->
-	  let tac' = Tacsubst.subst_tactic subst tac in
+	  let tac' = Genintern.generic_substitute subst tac in
 	  if tac==tac' then data.code.obj else Extern tac'
     in
     let name' = subst_path_atom subst data.name in
@@ -1025,16 +1172,17 @@ let add_transparency l b local dbnames =
       Lib.add_anonymous_leaf (inAutoHint hint))
     dbnames
 
-let add_extern pri pat tacast local dbname =
-  let pat = match pat with
+let add_extern info tacast local dbname =
+  let pat = match info.hint_pattern with
   | None -> None
   | Some (_, pat) -> Some pat
   in
-  let hint = make_hint ~local dbname (AddHints [make_extern pri pat tacast]) in
+  let hint = make_hint ~local dbname
+		       (AddHints [make_extern (Option.get info.hint_priority) 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_externs info tacast local dbnames =
+  List.iter (add_extern info tacast local) dbnames
 
 let add_trivials env sigma l local dbnames =
   List.iter
@@ -1048,15 +1196,16 @@ let (forward_intern_tac, extern_intern_tac) = Hook.make ()
 
 type hnf = bool
 
+type hint_info = (patvar list * constr_pattern) hint_info_gen
+
 type hints_entry =
-  | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * hint_term) list
+  | HintsResolveEntry of (hint_info * 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
+  | HintsModeEntry of global_reference * hint_mode list
+  | HintsExternEntry of hint_info * glob_tactic_expr
 
 let default_prepare_hint_ident = Id.of_string "H"
 
@@ -1064,10 +1213,12 @@ exception Found of constr * types
 
 let prepare_hint check (poly,local) env init (sigma,c) =
   let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in
-  (* We re-abstract over uninstantiated evars.
+  (* We re-abstract over uninstantiated evars and universes.
      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 sigma, subst = Evd.nf_univ_variables sigma in
+  let c = Vars.subst_univs_constr subst (Evarutil.nf_evar sigma c) in
+  let c = drop_extra_implicit_args 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
@@ -1081,7 +1232,7 @@ let prepare_hint check (poly,local) env init (sigma,c) =
 	(* 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
+    | _ -> Constr.iter find_next_evar c in
   let rec iter c =
     try find_next_evar c; c
     with Found (evar,t) ->
@@ -1090,11 +1241,11 @@ let prepare_hint check (poly,local) env init (sigma,c) =
       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';
+    if check then Pretyping.check_evars (Global.env()) Evd.empty sigma c';
     let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in
     if poly then IsConstr (c', diff)
     else if local then IsConstr (c', diff)
-    else (Global.push_context_set false diff;
+    else (Lib.add_anonymous_leaf (input_context_set diff);
 	  IsConstr (c', Univ.ContextSet.empty))
 
 let interp_hints poly =
@@ -1118,11 +1269,12 @@ let interp_hints poly =
 	(PathHints [gr], poly, IsGlobRef gr)
     | HintsConstr c -> (PathAny, poly, f poly c)
   in
-  let fres (pri, b, r) =
+  let fp = Constrintern.intern_constr_pattern (Global.env()) in
+  let fres (info, b, r) =
     let path, poly, gr = fi r in
-      (pri, poly, b, path, gr)
+    let info = { info with hint_pattern = Option.map fp info.hint_pattern } in
+      (info, 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)
@@ -1138,14 +1290,14 @@ let interp_hints poly =
           List.init (nconstructors ind) 
 	    (fun i -> let c = (ind,i+1) in
 		      let gr = ConstructRef c in
-			None, mib.Declarations.mind_polymorphic, true, 
+			empty_hint_info, 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)
+      HintsExternEntry ({ hint_priority = Some pri; hint_pattern = pat }, tacexp)
 
 let add_hints local dbnames0 h =
   if String.List.mem "nocore" dbnames0 then
@@ -1161,29 +1313,41 @@ let add_hints local dbnames0 h =
   | 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
+  | HintsExternEntry (info, tacexp) ->
+      add_externs info 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))
+		  (fun i ->
+		   let ctx = Univ.ContextSet.diff (Evd.universe_context_set evd)
+						  (Evd.universe_context_set sigma) in
+		   not (Univ.ContextSet.is_empty ctx),
+		   IsConstr (mkConstructU ((ind,i+1),u),ctx))
     | _ ->
-	[prepare_hint false (false,true) env sigma (evd,lem)]) lems
-
+       [match prepare_hint false (false,true) env sigma (evd,lem) with
+	| IsConstr (c, ctx) ->
+	   not (Univ.ContextSet.is_empty ctx), IsConstr (c, ctx)
+	| IsGlobRef _ -> assert false (* Impossible return value *) ]) 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 false) lems in
+    List.map_append (fun (poly, lem) ->
+		     make_resolves env sigma (eapply,true,false) empty_hint_info poly lem) lems in
   Hint_db.add_list env sigma hintlist' hint_db
 
 let make_local_hint_db env sigma ts eapply lems =
+  let map c =
+    let sigma = Sigma.Unsafe.of_evar_map sigma in
+    let Sigma (c, sigma, _) = c.delayed env sigma in
+    (Sigma.to_evar_map sigma, c)
+  in
+  let lems = List.map map lems in
   let sign = Environ.named_context env in
   let ts = match ts with
     | None -> Hint_db.transparent_state (searchtable_map "core") 
@@ -1193,12 +1357,6 @@ let make_local_hint_db env sigma ts eapply lems =
   add_hint_lemmas env sigma eapply lems
     (Hint_db.add_list env sigma 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
 
@@ -1218,23 +1376,25 @@ let make_db_list dbnames =
 let pr_hint_elt (c, _, _) = pr_constr c
 
 let pr_hint h = match h.obj with
-  | Res_pf (c, _) -> (str"apply " ++ pr_hint_elt c)
-  | ERes_pf (c, _) -> (str"eapply " ++ pr_hint_elt c)
+  | Res_pf (c, _) -> (str"simple apply " ++ pr_hint_elt c)
+  | ERes_pf (c, _) -> (str"simple eapply " ++ pr_hint_elt c)
   | Give_exact (c, _) -> (str"exact " ++ pr_hint_elt c)
   | Res_pf_THEN_trivial_fail (c, _) ->
-      (str"apply " ++ pr_hint_elt c ++ str" ; trivial")
+      (str"simple apply " ++ pr_hint_elt 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 ()
+        with e when CErrors.noncritical e -> Global.env ()
       in
-      (str "(*external*) " ++ Pptactic.pr_glob_tactic env tac)
+      (str "(*external*) " ++ Pptactic.pr_glb_generic env tac)
 
 let pr_id_hint (id, v) =
-  (pr_hint v.code ++ str"(level " ++ int v.pri ++ str", id " ++ int id ++ str ")" ++ spc ())
+  let pr_pat p = str", pattern " ++ pr_lconstr_pattern p in
+  (pr_hint v.code ++ str"(level " ++ int v.pri ++ pr_opt_no_spc pr_pat v.pat
+   ++ str", id " ++ int id ++ str ")" ++ spc ())
 
 let pr_hint_list hintlist =
   (str "  " ++ hov 0 (prlist pr_id_hint hintlist) ++ fnl ())
@@ -1248,7 +1408,7 @@ let pr_hints_db (name,db,hintlist) =
 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
+    let hints = List.map (fun v -> 0, v) (Hint_db.map_all Id.Pred.full c db) in
     (name, db, hints)
   in
   let valid_dbs = List.map validate dbs in
@@ -1270,9 +1430,9 @@ let pr_hint_term cl =
       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
+	      Hint_db.map_existential ~secvars:Id.Pred.full hdc cl
+	    else Hint_db.map_auto ~secvars:Id.Pred.full hdc cl
+	with Bound -> Hint_db.map_none ~secvars:Id.Pred.full
       in
       let fn db = List.map (fun x -> 0, x) (fn db) in
       List.map (fun (name, db) -> (name, db, fn db)) dbs
@@ -1290,13 +1450,18 @@ 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."
+  | [] -> CErrors.error "No focused goal."
   | g::_ ->
     pr_hint_term (Goal.V82.concl glss.Evd.sigma g)
 
+let pp_hint_mode = function
+  | ModeInput -> str"+"
+  | ModeNoHeadEvar -> str"!"
+  | ModeOutput -> str"-"
+
 (* 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_mode = prvect_with_sep spc pp_hint_mode in
   let pr_modes l = 
     if List.is_empty l then mt ()
     else str" (modes " ++ prlist_with_sep pr_comma pr_mode l ++ str")"
@@ -1344,10 +1509,15 @@ let print_mp mp =
 
 let is_imported h = try KNmap.find h.uid !statustable with Not_found -> true
 
+let warn_non_imported_hint =
+  CWarnings.create ~name:"non-imported-hint" ~category:"automation"
+         (fun (hint,mp) ->
+          strbrk "Hint used but not imported: " ++ hint ++ print_mp mp)
+
 let warn h x =
   let hint = pr_hint h in
   let (mp, _, _) = KerName.repr h.uid in
-  let () = msg_warning (str "Hint used but not imported: " ++ hint ++ print_mp mp) in
+  warn_non_imported_hint (hint,mp);
   Proofview.tclUNIT x
 
 let run_hint tac k = match !warn_hint with
diff --git a/tactics/hints.mli b/tactics/hints.mli
index 08ea71bb..1be3e0c5 100644
--- a/tactics/hints.mli
+++ b/tactics/hints.mli
@@ -10,7 +10,6 @@ open Pp
 open Util
 open Names
 open Term
-open Context
 open Environ
 open Globnames
 open Decl_kinds
@@ -26,6 +25,10 @@ exception Bound
 
 val decompose_app_bound : constr -> global_reference * constr array
 
+val secvars_of_hyps : Context.Named.t -> Id.Pred.t
+
+val empty_hint_info : 'a hint_info_gen
+
 (** Pre-created hint databases *)
 
 type 'a hint_ast =
@@ -34,21 +37,27 @@ type 'a hint_ast =
   | 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 *)
+  | Extern     of Genarg.glob_generic_argument       (* Hint Extern *)
 
 type hint
 type raw_hint = constr * types * Univ.universe_context_set
 
-type hints_path_atom = 
-  | PathHints of global_reference list
+type 'a hints_path_atom_gen =
+  | PathHints of 'a list
+  (* For forward hints, their names is the list of projections *)
   | PathAny
 
+type hints_path_atom = global_reference hints_path_atom_gen
+type hint_db_name = string
+
 type 'a with_metadata = private {
   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; (** the tactic to apply when the concl matches pat *)
+  db    : hint_db_name option;
+  secvars : Id.Pred.t; (** The section variables this hint depends on, as a predicate *)
+  code    : 'a; (** the tactic to apply when the concl matches pat *)
 }
 
 type full_hint = hint with_metadata
@@ -59,47 +68,63 @@ type search_entry
 
 type hint_entry
 
-type hints_path =
-  | PathAtom of hints_path_atom
-  | PathStar of hints_path
-  | PathSeq of hints_path * hints_path
-  | PathOr of hints_path * hints_path
+type 'a hints_path_gen =
+  | PathAtom of 'a hints_path_atom_gen
+  | PathStar of 'a hints_path_gen
+  | PathSeq of 'a hints_path_gen * 'a hints_path_gen
+  | PathOr of 'a hints_path_gen * 'a hints_path_gen
   | PathEmpty
   | PathEpsilon
 
+type pre_hints_path = Libnames.reference hints_path_gen
+type hints_path = global_reference hints_path_gen
+    
 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_atom : hints_path_atom -> Pp.std_ppcmds
+val pp_hints_path_gen : ('a -> Pp.std_ppcmds) -> 'a hints_path_gen -> Pp.std_ppcmds
+val pp_hints_path_atom : ('a -> Pp.std_ppcmds) -> 'a hints_path_atom_gen -> Pp.std_ppcmds
 val pp_hints_path : hints_path -> Pp.std_ppcmds
+val pp_hint_mode : hint_mode -> Pp.std_ppcmds
+val glob_hints_path_atom :
+  Libnames.reference hints_path_atom_gen -> Globnames.global_reference hints_path_atom_gen
+val glob_hints_path :
+  Libnames.reference hints_path_gen -> Globnames.global_reference hints_path_gen
 
 module Hint_db :
   sig
     type t
-    val empty : transparent_state -> bool -> t
+    val empty : ?name:hint_db_name -> transparent_state -> bool -> t
     val find : global_reference -> t -> search_entry
-    val map_none : t -> full_hint list
+
+    (** All hints which have no pattern.
+     * [secvars] represent the set of section variables that
+     * can be used in the hint. *)
+    val map_none : secvars:Id.Pred.t -> t -> full_hint list
 
     (** All hints associated to the reference *)
-    val map_all : global_reference -> t -> full_hint list
+    val map_all : secvars:Id.Pred.t -> global_reference -> t -> full_hint 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 -> full_hint list
+    val map_existential : secvars:Id.Pred.t ->
+      (global_reference * constr array) -> constr -> t -> full_hint 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 -> full_hint list
+    val map_eauto : secvars:Id.Pred.t -> (global_reference * constr array) -> constr -> t -> full_hint list
 
     (** All hints associated to the reference, respecting modes if evars appear in the 
 	arguments. *)
-    val map_auto : (global_reference * constr array) -> constr -> t -> full_hint list
+    val map_auto : secvars:Id.Pred.t ->
+       (global_reference * constr array) -> constr -> t -> full_hint list
 
     val add_one : env -> evar_map -> hint_entry -> t -> t
     val add_list : env -> evar_map -> 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 -> full_hint list -> unit) -> t -> unit
+    val iter : (global_reference option ->
+                hint_mode array list -> full_hint list -> unit) -> t -> unit
 
     val use_dn : t -> bool
     val transparent_state : t -> transparent_state
@@ -111,26 +136,25 @@ module Hint_db :
     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_info = (patvar list * constr_pattern) hint_info_gen
+
 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
+  | HintsResolveEntry of
+    (hint_info * 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
+  | HintsModeEntry of global_reference * hint_mode list
+  | HintsExternEntry of hint_info * Tacexpr.glob_tactic_expr
 
 val searchtable_map : hint_db_name -> hint_db
 
@@ -157,22 +181,34 @@ val prepare_hint : bool (* Check no remaining evars *) ->
   (bool * bool) (* polymorphic or monomorphic, local or global *) ->
   env -> evar_map -> open_constr -> hint_term
 
-(** [make_exact_entry pri (c, ctyp)].
+(** [make_exact_entry info (c, ctyp, ctx)].
    [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 -> 
+   [ctyp] is the type of [c].
+   [ctx] is its (refreshable) universe context. 
+   In info:
+   [hint_priority] is the hint's desired priority, it is 0 if unspecified
+   [hint_pattern] is the hint's desired pattern, it is inferred if not specified
+*)
+
+val make_exact_entry : env -> evar_map -> hint_info -> polymorphic -> ?name:hints_path_atom ->
   (constr * types * Univ.universe_context_set) -> hint_entry
 
-(** [make_apply_entry (eapply,hnf,verbose) pri (c,cty)].
+(** [make_apply_entry (eapply,hnf,verbose) info (c,cty,ctx))].
    [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]. *)
+   [cty] is the type of [c].
+   [ctx] is its (refreshable) universe context. 
+   In info:
+   [hint_priority] is the hint's desired priority, it is computed as the number of products in [cty]
+   if unspecified
+   [hint_pattern] is the hint's desired pattern, it is inferred from the conclusion of [cty]
+   if not specified
+*)
 
 val make_apply_entry :
-  env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> 
+  env -> evar_map -> bool * bool * bool -> hint_info -> polymorphic -> ?name:hints_path_atom ->
   (constr * types * Univ.universe_context_set) -> hint_entry
 
 (** A constr which is Hint'ed will be:
@@ -183,7 +219,7 @@ val make_apply_entry :
          has missing arguments. *)
 
 val make_resolves :
-  env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> 
+  env -> evar_map -> bool * bool * bool -> hint_info -> polymorphic -> ?name:hints_path_atom ->
   hint_term -> hint_entry list
 
 (** [make_resolve_hyp hname htyp].
@@ -192,7 +228,7 @@ val make_resolves :
    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
+  env -> evar_map -> Context.Named.Declaration.t -> hint_entry list
 
 (** [make_extern pri pattern tactic_expr] *)
 
@@ -214,7 +250,7 @@ val extern_intern_tac :
    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_local_hint_db : env -> evar_map -> ?ts:transparent_state -> bool -> Tacexpr.delayed_open_constr list -> hint_db
 
 val make_db_list : hint_db_name list -> hint_db list
 
diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml
index 29d848ca..7b52a9ce 100644
--- a/tactics/hipattern.ml4
+++ b/tactics/hipattern.ml
@@ -6,10 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "grammar/grammar.cma grammar/q_constr.cmo" i*)
-
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Term
@@ -19,6 +17,7 @@ open Constr_matching
 open Coqlib
 open Declarations
 open Tacmach.New
+open Context.Rel.Declaration
 
 (* I implemented the following functions which test whether a term t
    is an inductive but non-recursive type, a general conjuction, a
@@ -101,13 +100,16 @@ let match_with_one_constructor style onlybinary allow_rec t =
 	      (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in
 	  if
 	    List.for_all
-	      (fun (_,b,c) -> Option.is_empty b && isRel c && Int.equal (destRel c) mib.mind_nparams) ctx
+	      (fun decl -> let c = get_type decl in
+	                   is_local_assum decl &&
+			   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
+	  let cargs = List.map get_type (prod_assum ctyp) in
 	  if not (is_lax_conjunction style) || has_nodep_prod ctyp then
 	    (* Record or non strict conjunction *)
 	    Some (hdapp,List.rev cargs)
@@ -152,7 +154,7 @@ let is_tuple t =
 let test_strict_disjunction n lc =
   Array.for_all_i (fun i c ->
     match (prod_assum (snd (decompose_prod_n_assum n c))) with
-    | [_,None,c] -> isRel c && Int.equal (destRel c) (n - i)
+    | [LocalAssum (_,c)] -> isRel c && Int.equal (destRel c) (n - i)
     | _ -> false) 0 lc
 
 let match_with_disjunction ?(strict=false) ?(onlybinary=false) t =
@@ -239,9 +241,36 @@ type equation_kind =
 
 exception NoEquationFound
 
-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 Glob_term
+open Decl_kinds
+open Evar_kinds
+
+let mkPattern c = snd (Patternops.pattern_of_glob_constr c)
+let mkGApp f args = GApp (Loc.ghost, f, args)
+let mkGHole =
+  GHole (Loc.ghost, QuestionMark (Define false), Misctypes.IntroAnonymous, None)
+let mkGProd id c1 c2 =
+  GProd (Loc.ghost, Name (Id.of_string id), Explicit, c1, c2)
+let mkGArrow c1 c2 =
+  GProd (Loc.ghost, Anonymous, Explicit, c1, c2)
+let mkGVar id = GVar (Loc.ghost, Id.of_string id)
+let mkGPatVar id = GPatVar(Loc.ghost, (false, Id.of_string id))
+let mkGRef r = GRef (Loc.ghost, Lazy.force r, None)
+let mkGAppRef r args = mkGApp (mkGRef r) args
+
+(** forall x : _, _ x x *)
+let coq_refl_leibniz1_pattern =
+  mkPattern (mkGProd "x" mkGHole (mkGApp mkGHole [mkGVar "x"; mkGVar "x";]))
+
+(** forall A:_, forall x:A, _ A x x *)
+let coq_refl_leibniz2_pattern =
+  mkPattern (mkGProd "A" mkGHole (mkGProd "x" (mkGVar "A")
+    (mkGApp mkGHole [mkGVar "A"; mkGVar "x"; mkGVar "x";])))
+
+(** forall A:_, forall x:A, _ A x A x *)
+let coq_refl_jm_pattern       =
+  mkPattern (mkGProd "A" mkGHole (mkGProd "x" (mkGVar "A")
+    (mkGApp mkGHole [mkGVar "A"; mkGVar "x"; mkGVar "A"; mkGVar "x";])))
 
 open Globnames
 
@@ -297,7 +326,8 @@ let is_equality_type t = op2bool (match_with_equality_type t)
 
 (* Arrows/Implication/Negation *)
 
-let coq_arrow_pattern = PATTERN [ ?X1 -> ?X2 ]
+(** X1 -> X2 **)
+let coq_arrow_pattern = mkPattern (mkGArrow (mkGPatVar "X1") (mkGPatVar "X2"))
 
 let match_arrow_pattern t =
   let result = matches coq_arrow_pattern t in
@@ -376,33 +406,27 @@ let rec first_match matcher = function
 
 (*** Equality *)
 
-(* Patterns "(eq ?1 ?2 ?3)" and "(identity ?1 ?2 ?3)" *)
-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 match_eq eqn eq_pat =
-  let pat =
-    try Lazy.force eq_pat
-    with e when Errors.noncritical e -> raise PatternMatchingFailure
+let match_eq eqn (ref, hetero) =
+  let ref =
+    try Lazy.force ref
+    with e when CErrors.noncritical e -> raise PatternMatchingFailure
   in
-  match Id.Map.bindings (matches pat eqn) with
-    | [(m1,t);(m2,x);(m3,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 (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3 && Id.equal m4 meta4);
-	HeterogenousEq (t,x,t',x')
-    | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 or 4 terms")
+  match kind_of_term eqn with
+  | App (c, [|t; x; y|]) ->
+    if not hetero && is_global ref c then PolymorphicLeibnizEq (t, x, y)
+    else raise PatternMatchingFailure
+  | App (c, [|t; x; t'; x'|]) ->
+    if hetero && is_global ref c then HeterogenousEq (t, x, t', x')
+    else raise PatternMatchingFailure
+  | _ -> raise PatternMatchingFailure
 
 let no_check () = true
 let check_jmeq_loaded () = Library.library_is_loaded Coqlib.jmeq_module
 
 let equalities =
-  [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]
+  [(coq_eq_ref, false), no_check, build_coq_eq_data;
+   (coq_jmeq_ref, true), check_jmeq_loaded, build_coq_jmeq_data;
+   (coq_identity_ref, false), no_check, build_coq_identity_data]
 
 let find_eq_data eqn = (* fails with PatternMatchingFailure *)
   let d,k = first_match (match_eq eqn) equalities in
@@ -433,11 +457,14 @@ let find_this_eq_data_decompose gl eqn =
       error "Don't know what to do with JMeq on arguments not of same type." in
   (lbeq,u,eq_args)
 
-let match_eq_nf gls eqn eq_pat =
-  match Id.Map.bindings (pf_matches gls (Lazy.force eq_pat) eqn) with
+let match_eq_nf gls eqn (ref, hetero) =
+  let n = if hetero then 4 else 3 in
+  let args = List.init n (fun i -> mkGPatVar ("X" ^ string_of_int (i + 1))) in
+  let pat = mkPattern (mkGAppRef ref args) in
+  match Id.Map.bindings (pf_matches gls pat eqn) with
     | [(m1,t);(m2,x);(m3,y)] ->
         assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3);
-	(t,pf_whd_betadeltaiota gls x,pf_whd_betadeltaiota gls y)
+	(t,pf_whd_all gls x,pf_whd_all gls y)
     | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 terms")
 
 let dest_nf_eq gls eqn =
@@ -460,7 +487,8 @@ let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *)
   match_sigma ex
 
 (* Pattern "(sig ?1 ?2)" *)
-let coq_sig_pattern = lazy PATTERN [ %coq_sig_ref ?X1 ?X2 ]
+let coq_sig_pattern =
+  lazy (mkPattern (mkGAppRef coq_sig_ref [mkGPatVar "X1"; mkGPatVar "X2"]))
 
 let match_sigma t =
   match Id.Map.bindings (matches (Lazy.force coq_sig_pattern) t) with
@@ -476,17 +504,25 @@ let is_matching_sigma t = is_matching (Lazy.force coq_sig_pattern) t
 (* Pattern "{<?1>x=y}+{~(<?1>x=y)}" *)
 (* i.e. "(sumbool (eq ?1 x y) ~(eq ?1 x y))" *)
 
-let coq_eqdec_inf_pattern =
- lazy PATTERN [ { ?X2 = ?X3 :> ?X1 } + { ~ ?X2 = ?X3 :> ?X1 } ]
+let coq_eqdec ~sum ~rev =
+  lazy (
+    let eqn = mkGAppRef coq_eq_ref (List.map mkGPatVar ["X1"; "X2"; "X3"]) in
+    let args = [eqn; mkGAppRef coq_not_ref [eqn]] in
+    let args = if rev then List.rev args else args in
+    mkPattern (mkGAppRef sum args)
+  )
+
+(** { ?X2 = ?X3 :> ?X1 } + { ~ ?X2 = ?X3 :> ?X1 } *)
+let coq_eqdec_inf_pattern = coq_eqdec ~sum:coq_sumbool_ref ~rev:false
 
-let coq_eqdec_inf_rev_pattern =
- lazy PATTERN [ { ~ ?X2 = ?X3 :> ?X1 } + { ?X2 = ?X3 :> ?X1 } ]
+(** { ~ ?X2 = ?X3 :> ?X1 } + { ?X2 = ?X3 :> ?X1 } *)
+let coq_eqdec_inf_rev_pattern = coq_eqdec ~sum:coq_sumbool_ref ~rev:true
 
-let coq_eqdec_pattern =
- lazy PATTERN [ %coq_or_ref (?X2 = ?X3 :> ?X1) (~ ?X2 = ?X3 :> ?X1) ]
+(** %coq_or_ref (?X2 = ?X3 :> ?X1) (~ ?X2 = ?X3 :> ?X1) *)
+let coq_eqdec_pattern = coq_eqdec ~sum:coq_or_ref ~rev:false
 
-let coq_eqdec_rev_pattern =
- lazy PATTERN [ %coq_or_ref (~ ?X2 = ?X3 :> ?X1) (?X2 = ?X3 :> ?X1) ]
+(** %coq_or_ref (~ ?X2 = ?X3 :> ?X1) (?X2 = ?X3 :> ?X1) *)
+let coq_eqdec_rev_pattern = coq_eqdec ~sum:coq_or_ref ~rev:true
 
 let op_or = coq_or_ref
 let op_sum = coq_sumbool_ref
@@ -506,8 +542,8 @@ let match_eqdec t =
   | _ -> anomaly (Pp.str "Unexpected pattern")
 
 (* Patterns "~ ?" and "? -> False" *)
-let coq_not_pattern = lazy PATTERN [ ~ _ ]
-let coq_imp_False_pattern = lazy PATTERN [ _ -> %coq_False_ref ]
+let coq_not_pattern = lazy (mkPattern (mkGAppRef coq_not_ref [mkGHole]))
+let coq_imp_False_pattern = lazy (mkPattern (mkGArrow mkGHole (mkGRef coq_False_ref)))
 
 let is_matching_not t = is_matching (Lazy.force coq_not_pattern) t
 let is_matching_imp_False t = is_matching (Lazy.force coq_imp_False_pattern) t
diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli
index 32938ce5..7cc41f1b 100644
--- a/tactics/hipattern.mli
+++ b/tactics/hipattern.mli
@@ -119,11 +119,11 @@ 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 : [ `NF ] Proofview.Goal.t -> constr ->
+val find_eq_data_decompose : ([ `NF ], 'r) 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 : [ `NF ] Proofview.Goal.t -> constr ->
+val find_this_eq_data_decompose : ([ `NF ], 'r) Proofview.Goal.t -> constr ->
       coq_eq_data * Univ.universe_instance * (types * constr * constr)
 
 (** A variant that returns more informative structure on the equality found *)
@@ -144,7 +144,7 @@ val is_matching_sigma : constr -> bool
 val match_eqdec : constr -> bool * constr * constr * constr * constr
 
 (** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *)
-val dest_nf_eq : [ `NF ] Proofview.Goal.t -> constr -> (constr * constr * constr)
+val dest_nf_eq : ([ `NF ], 'r) 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 22bacdfc..bda16b01 100644
--- a/tactics/inv.ml
+++ b/tactics/inv.ml
@@ -7,13 +7,12 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
 open Term
 open Vars
-open Context
 open Termops
 open Namegen
 open Environ
@@ -27,9 +26,9 @@ open Elim
 open Equality
 open Misctypes
 open Tacexpr
+open Sigma.Notations
 open Proofview.Notations
-
-let clear hyps = Proofview.V82.tactic (clear hyps)
+open Context.Named.Declaration
 
 let var_occurs_in_pf gl id =
   let env = Proofview.Goal.env gl in
@@ -96,7 +95,7 @@ let make_inv_predicate env evd indf realargs id status concl =
 	  (* We lift to make room for the equations *)
 	  (hyps,lift nrealargs bodypred)
   in
-  let nhyps = rel_context_length hyps in
+  let nhyps = Context.Rel.length hyps in
   let env' = push_rel_context hyps env in
   (* Now the arity is pushed, and we need to construct the pairs
    * ai,mkRel(n-i+1) *)
@@ -181,9 +180,9 @@ let make_inv_predicate env evd indf realargs id status concl =
 let dependent_hyps env id idlist gl =
   let rec dep_rec =function
     | [] -> []
-    | (id1,_,_)::l ->
+    | d::l ->
 	(* Update the type of id1: it may have been subject to rewriting *)
-	let d = pf_get_hyp id1 gl in
+	let d = pf_get_hyp (get_id d) gl in
 	if occur_var_in_decl env id d
         then d :: dep_rec l
         else dep_rec l
@@ -192,8 +191,8 @@ let dependent_hyps env id idlist gl =
 
 let split_dep_and_nodep hyps gl =
   List.fold_right
-    (fun (id,_,_ as d) (l1,l2) ->
-       if var_occurs_in_pf gl id then (d::l1,l2) else (l1,d::l2))
+    (fun d (l1,l2) ->
+       if var_occurs_in_pf gl (get_id d) then (d::l1,l2) else (l1,d::l2))
     hyps ([],[])
 
 (* Computation of dids is late; must have been done in rewrite_equations*)
@@ -269,14 +268,14 @@ Nota: with Inversion_clear, only four useless hypotheses
 
 let generalizeRewriteIntros as_mode tac depids id =
   Proofview.tclENV >>= fun env ->
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { 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 *)
      reintros (ids_of_named_context dids)])
-  end
+  end }
 
 let error_too_many_names pats =
   let loc = Loc.join_loc (fst (List.hd pats)) (fst (List.last pats)) in
@@ -284,10 +283,10 @@ let error_too_many_names pats =
   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 ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (fst (run_delayed env Evd.empty c)))) pats ++
     str ".")
 
-let rec get_names (allow_conj,issimple) (loc,pat as x) = match pat with
+let 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 _) ->
@@ -296,17 +295,17 @@ let rec get_names (allow_conj,issimple) (loc,pat as x) = match pat with
       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])
+  | IntroAction (IntroOrAndPattern (IntroAndPattern [])) when allow_conj -> (None, [])
+  | IntroAction (IntroOrAndPattern (IntroAndPattern ((_,IntroNaming (IntroIdentifier id)) :: _ as l) | IntroOrPattern [(_,IntroNaming (IntroIdentifier id)) :: _ as l ]))
       when allow_conj -> (Some id,l)
-  | IntroAction (IntroOrAndPattern [_]) ->
+  | IntroAction (IntroOrAndPattern (IntroAndPattern _)) ->
       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) ->
+  | IntroAction (IntroOrAndPattern (IntroOrPattern _)) ->
       error "Disjunctive patterns not allowed for inversion equations."
   | IntroAction (IntroApplyOn (c,pat)) ->
       error "Apply patterns not allowed for inversion equations."
@@ -338,7 +337,7 @@ let projectAndApply as_mode thin avoid id eqname names depids =
       (if thin then clear [id] else (remember_first_eq id eqname; tclIDTAC))
   in
   let substHypIfVariable tac id =
-    Proofview.Goal.nf_enter begin fun gl ->
+    Proofview.Goal.nf_enter { 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
@@ -346,7 +345,7 @@ let projectAndApply as_mode thin avoid id eqname names depids =
     | 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
+    end }
   in
   let deq_trailer id clear_flag _ neqns =
     assert (clear_flag == None);
@@ -373,7 +372,7 @@ let projectAndApply as_mode thin avoid id eqname names depids =
     id
 
 let nLastDecls i tac =
-  Proofview.Goal.nf_enter (fun gl -> tac (nLastDecls gl i))
+  Proofview.Goal.nf_enter { enter = begin fun gl -> tac (nLastDecls gl i) end }
 
 (* Introduction of the equations on arguments
    othin: discriminates Simple Inversion, Inversion and Inversion_clear
@@ -381,10 +380,10 @@ let nLastDecls i tac =
      Some thin: the equations are rewritten, and cleared if thin is true *)
 
 let rewrite_equations as_mode othin neqns names ba =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { 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
+  let avoid = if as_mode then List.map get_id nodepids else [] in
   match othin with
     | Some thin ->
         tclTHENLIST
@@ -399,11 +398,11 @@ let rewrite_equations as_mode othin neqns names ba =
 		 (onLastHypId (fun id ->
 		   tclTRY (projectAndApply as_mode thin avoid id first_eq names depids)))))
 	       names;
-	     tclMAP (fun (id,_,_) -> tclIDTAC >>= fun () -> (* delay for [first_eq]. *)
-               let idopt = if as_mode then Some id else None in
+	     tclMAP (fun d -> tclIDTAC >>= fun () -> (* delay for [first_eq]. *)
+               let idopt = if as_mode then Some (get_id d) else None in
 	       intro_move idopt (if thin then MoveLast else !first_eq))
 	       nodepids;
-	     (tclMAP (fun (id,_,_) -> tclTRY (clear [id])) depids)]
+	     (tclMAP (fun d -> tclTRY (clear [get_id d])) depids)]
     | None ->
         (* simple inversion *)
         if as_mode then
@@ -414,7 +413,7 @@ let rewrite_equations as_mode othin neqns names ba =
              [tclDO neqns intro;
               bring_hyps nodepids;
               clear (ids_of_named_context nodepids)])
-  end
+  end }
 
 let interp_inversion_kind = function
   | SimpleInversion -> None
@@ -431,8 +430,9 @@ let rewrite_equations_tac as_mode othin id neqns names ba =
     tac
 
 let raw_inversion inv_kind id status names =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
     let sigma = Proofview.Goal.sigma gl in
+    let sigma = Sigma.to_evar_map sigma in
     let env = Proofview.Goal.env gl in
     let concl = Proofview.Goal.concl gl in
     let c = mkVar id in
@@ -440,7 +440,7 @@ let raw_inversion inv_kind id status names =
       try pf_apply Tacred.reduce_to_atomic_ind gl (pf_unsafe_type_of gl c)
       with UserError _ ->
         let msg = str "The type of " ++ pr_id id ++ str " is not inductive." in
-        Errors.errorlabstrm "" msg
+        CErrors.errorlabstrm "" msg
     in
     let IndType (indf,realargs) = find_rectype env sigma t in
     let evdref = ref sigma in
@@ -457,19 +457,21 @@ let raw_inversion inv_kind id status names =
     in
     let refined id =
       let prf = mkApp (mkVar id, args) in
-      Proofview.Refine.refine (fun h -> h, prf)
+      Refine.refine { run = fun h -> Sigma (prf, h, Sigma.refl) }
     in
     let neqns = List.length realargs in
     let as_mode = names != None in
-    tclTHEN (Proofview.Unsafe.tclEVARS sigma)
+    let tac =
       (tclTHENS
         (assert_before Anonymous cut_concl)
         [case_tac names
-            (introCaseAssumsThen
+            (introCaseAssumsThen false (* ApplyOn not supported by inversion *)
                (rewrite_equations_tac as_mode inv_kind id neqns))
             (Some elim_predicate) ind (c, t);
         onLastHypId (fun id -> tclTHEN (refined id) reflexivity)])
-  end
+    in
+    Sigma.Unsafe.of_pair (tac, sigma)
+  end }
 
 (* Error messages of the inversion tactics *)
 let wrap_inv_error id = function (e, info) -> match e with
@@ -511,12 +513,12 @@ let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id)
  * back to their places in the hyp-list. *)
 
 let invIn k names ids id =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { 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 ->
+      Proofview.Goal.enter { 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)
@@ -525,7 +527,7 @@ let invIn k names ids id =
           intros_replacing ids
         else
           tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids)
-      end
+      end }
     in
     Proofview.tclORELSE
       (tclTHENLIST
@@ -533,7 +535,7 @@ let invIn k names ids id =
           inversion k NoDep names id;
           intros_replace_ids])
       (wrap_inv_error id)
-  end
+  end }
 
 let invIn_gen k names idl = try_intros_until (invIn k names idl)
 
diff --git a/tactics/leminv.ml b/tactics/leminv.ml
index 894d4474..40b600c8 100644
--- a/tactics/leminv.ml
+++ b/tactics/leminv.ml
@@ -7,14 +7,13 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Term
 open Vars
 open Termops
 open Namegen
-open Context
 open Evd
 open Printer
 open Reductionops
@@ -27,6 +26,8 @@ open Declare
 open Tacticals.New
 open Tactics
 open Decl_kinds
+open Proofview.Notations
+open Context.Named.Declaration
 
 let no_inductive_inconstr env sigma constr =
   (str "Cannot recognize an inductive predicate in " ++
@@ -113,15 +114,15 @@ let max_prefix_sign lid sign =
     | id::l -> snd (max_rec (id, sign_prefix id sign) l)
 *)
 let rec add_prods_sign env sigma t =
-  match kind_of_term (whd_betadeltaiota env sigma t) with
+  match kind_of_term (whd_all env sigma t) with
     | Prod (na,c1,b) ->
 	let id = id_of_name_using_hdchar env t na in
 	let b'= subst1 (mkVar id) b in
-        add_prods_sign (push_named (id,None,c1) env) sigma b'
+        add_prods_sign (push_named (LocalAssum (id,c1)) env) sigma b'
     | LetIn (na,c1,t1,b) ->
 	let id = id_of_name_using_hdchar env t na in
 	let b'= subst1 (mkVar id) b in
-        add_prods_sign (push_named (id,Some c1,t1) env) sigma b'
+        add_prods_sign (push_named (LocalDef (id,c1,t1)) env) sigma b'
     | _ -> (env,t)
 
 (* [dep_option] indicates whether the inversion lemma is dependent or not.
@@ -154,9 +155,10 @@ let compute_first_inversion_scheme env sigma ind sort dep_option =
       let ivars = global_vars env i in
       let revargs,ownsign =
 	fold_named_context
-	  (fun env (id,_,_ as d) (revargs,hyps) ->
+	  (fun env d (revargs,hyps) ->
+             let id = get_id d in
              if Id.List.mem id ivars then
-	       ((mkVar id)::revargs,add_named_decl d hyps)
+	       ((mkVar id)::revargs, Context.Named.add d hyps)
 	     else
 	       (revargs,hyps))
           env ~init:([],[])
@@ -165,8 +167,8 @@ let compute_first_inversion_scheme env sigma ind sort dep_option =
       let goal = mkArrow i (applist(mkVar p, List.rev revargs)) in
       (pty,goal)
   in
-  let npty = nf_betadeltaiota env sigma pty in
-  let extenv = push_named (p,None,npty) env in
+  let npty = nf_all env sigma pty in
+  let extenv = push_named (LocalAssum (p,npty)) env in
   extenv, goal
 
 (* [inversion_scheme sign I]
@@ -200,13 +202,13 @@ let inversion_scheme env sigma t sort dep_option inv_op =
       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 global_named_context = Global.named_context_val () in
   let ownSign = ref begin
     fold_named_context
-      (fun env (id,_,_ as d) sign ->
-         if mem_named_context id global_named_context then sign
-	 else add_named_decl d sign)
-      invEnv ~init:empty_named_context
+      (fun env d sign ->
+         if mem_named_context_val (get_id d) global_named_context then sign
+	 else Context.Named.add d sign)
+      invEnv ~init:Context.Named.empty
   end in
   let avoid = ref [] in
   let { sigma=sigma } = Proof.V82.subgoals pf in
@@ -217,9 +219,9 @@ let inversion_scheme env sigma t sort dep_option inv_op =
 	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;
+	ownSign := Context.Named.add (LocalAssum (h,ty)) !ownSign;
 	applist (mkVar h, inst)
-    | _ -> map_constr fill_holes c
+    | _ -> Constr.map fill_holes c
   in
   let c = fill_holes pfterm in
   (* warning: side-effect on ownSign *)
@@ -269,7 +271,7 @@ let lemInv id c gls =
 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 ->
+  Proofview.Goal.nf_enter { 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
@@ -281,7 +283,7 @@ let lemInvIn id c ids =
     in
     ((tclTHEN (tclTHEN (bring_hyps hyps) (Proofview.V82.tactic (lemInv id c)))
         (intros_replace_ids)))
-  end
+  end }
 
 let lemInvIn_gen id c l = try_intros_until (fun id -> lemInvIn id c l) id
 
diff --git a/tactics/tactic_matching.ml b/tactics/tactic_matching.ml
index 80786058..004492e7 100644
--- a/tactics/tactic_matching.ml
+++ b/tactics/tactic_matching.ml
@@ -11,6 +11,7 @@
 
 open Names
 open Tacexpr
+open Context.Named.Declaration
 
 (** [t] is the type of matching successes. It ultimately contains a
     {!Tacexpr.glob_tactic_expr} representing the left-hand side of the
@@ -102,7 +103,7 @@ let verify_metas_coherence env sigma (ln1,lcm) (ln,lm) =
   (merged, Id.Map.merge merge lcm lm)
 
 let matching_error =
-  Errors.UserError ("tactic matching" , Pp.str "No matching clauses for match.")
+  CErrors.UserError ("tactic matching" , Pp.str "No matching clauses for match.")
 
 let imatching_error = (matching_error, Exninfo.null)
 
@@ -278,9 +279,10 @@ module PatternMatching (E:StaticEnvironment) = struct
       [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 () <*>
+    pick hyps >>= fun decl ->
+    let id = get_id decl in
+    let refresh = is_local_def decl in
+    pattern_match_term refresh pat (get_type decl) () <*>
     put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*>
     return id
 
@@ -290,12 +292,12 @@ module PatternMatching (E:StaticEnvironment) = struct
       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) ->
+      | LocalDef (id,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
+      | LocalAssum (id,hyp) -> fail
 
   (** [hyp_match pat hyps] dispatches to
       {!hyp_match_type} or {!hyp_match_body_and_type} depending on whether
@@ -317,7 +319,7 @@ module PatternMatching (E:StaticEnvironment) = struct
         (* 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 select_matched_hyp decl = Id.equal (get_id decl) matched_hyp in
         let hyps = CList.remove_first select_matched_hyp hyps in
         hyp_pattern_list_match pats hyps lhs
     | [] -> return lhs
diff --git a/tactics/tactic_matching.mli b/tactics/tactic_matching.mli
index d8e6dd0a..090207bc 100644
--- a/tactics/tactic_matching.mli
+++ b/tactics/tactic_matching.mli
@@ -43,7 +43,7 @@ val match_term :
 val match_goal:
   Environ.env ->
   Evd.evar_map ->
-  Context.named_context ->
+  Context.Named.t ->
   Term.constr ->
   (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list ->
   Tacexpr.glob_tactic_expr t Proofview.tactic
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
index f5922411..66da9ee1 100644
--- a/tactics/tacticals.ml
+++ b/tactics/tacticals.ml
@@ -7,15 +7,16 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Term
 open Termops
-open Context
 open Declarations
 open Tacmach
 open Clenv
+open Sigma.Notations
+open Context.Named.Declaration
 
 (************************************************************************)
 (* Tacticals re-exported from the Refiner module                        *)
@@ -69,7 +70,7 @@ let nthDecl m gl =
   try List.nth (pf_hyps gl) (m-1)
   with Failure _ -> error "No such assumption."
 
-let nthHypId m gl = pi1 (nthDecl m gl)
+let nthHypId m gl = nthDecl m gl |> get_id
 let nthHyp m gl   = mkVar (nthHypId m gl)
 
 let lastDecl gl   = nthDecl 1 gl
@@ -80,7 +81,7 @@ let nLastDecls n 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)
+let nLastHypsId n gl = List.map get_id (nLastDecls n gl)
 let nLastHyps n gl   = List.map mkVar (nLastHypsId n gl)
 
 let onNthDecl m tac gl  = tac (nthDecl m gl) gl
@@ -98,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,_,_) -> Id.equal hyp id) (pf_hyps gl))
+  fst (List.split_when (Id.equal id % get_id) (pf_hyps gl))
 
 (***************************************)
 (*           Clause Tacticals          *)
@@ -147,14 +148,16 @@ type branch_args = {
   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 *)
+  nassums    : int;         (* number of assumptions/letin to be introduced *)
   branchsign : bool list;   (* the signature of the branch.
-                               true=recursive argument, false=constant *)
+                               true=assumption, false=let-in *)
   branchnames : Tacexpr.intro_patterns}
 
 type branch_assumptions = {
-  ba        : branch_args;     (* the branch args *)
-  assums    : named_context}   (* the list of assumptions introduced *)
+  ba        : branch_args;       (* the branch args *)
+  assums    : Context.Named.t}   (* the list of assumptions introduced *)
+
+open Misctypes
 
 let fix_empty_or_and_pattern nv l =
   (* 1- The syntax does not distinguish between "[ ]" for one clause with no
@@ -162,36 +165,78 @@ let fix_empty_or_and_pattern nv l =
   (* 2- More generally, we admit "[ ]" for any disjunctive pattern of
      arbitrary length *)
   match l with
-  | [[]] -> List.make nv []
+  | IntroOrPattern [[]] -> IntroOrPattern (List.make nv [])
   | _ -> l
 
-let check_or_and_pattern_size loc names n =
-  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
-	++ str " branches.")
-
-let compute_induction_names n = function
+let check_or_and_pattern_size check_and loc names branchsigns =
+  let n = Array.length branchsigns in
+  let msg p1 p2 = strbrk "a conjunctive pattern made of " ++ int p1 ++ (if p1 == p2 then mt () else str " or " ++ int p2) ++ str " patterns" in
+  let err1 p1 p2 =
+    user_err_loc (loc,"",str "Expects " ++ msg p1 p2 ++ str ".") in
+  let errn n =
+    user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n
+	++ str " branches.") in
+  let err1' p1 p2 =
+    user_err_loc (loc,"",strbrk "Expects a disjunctive pattern with 1 branch or " ++ msg p1 p2 ++ str ".") in
+  let errforthcoming loc =
+    user_err_loc (loc,"",strbrk "Unexpected non atomic pattern.") in
+  match names with
+  | IntroAndPattern l ->
+      if not (Int.equal n 1) then errn n;
+      let l' = List.filter (function _,IntroForthcoming _ -> true | _,IntroNaming _ | _,IntroAction _ -> false) l in
+      if l' != [] then errforthcoming (fst (List.hd l'));
+      if check_and then
+        let p1 = List.count (fun x -> x) branchsigns.(0) in
+        let p2 = List.length branchsigns.(0) in
+        let p = List.length l in
+        if not (Int.equal p p1 || Int.equal p p2) then err1 p1 p2;
+        if Int.equal p p1 then
+          IntroAndPattern
+            (List.extend branchsigns.(0) (Loc.ghost,IntroNaming IntroAnonymous) l)
+        else
+          names
+      else
+        names
+  | IntroOrPattern ll ->
+      if not (Int.equal n (List.length ll)) then
+        if Int.equal n 1 then
+          let p1 = List.count (fun x -> x) branchsigns.(0) in
+          let p2 = List.length branchsigns.(0) in
+          err1' p1 p2 else errn n;
+      names
+
+let get_and_check_or_and_pattern_gen check_and loc names branchsigns =
+  let names = check_or_and_pattern_size check_and loc names branchsigns in
+  match names with
+  | IntroAndPattern l -> [|l|]
+  | IntroOrPattern l -> Array.of_list l
+
+let get_and_check_or_and_pattern = get_and_check_or_and_pattern_gen true
+
+let compute_induction_names_gen check_and branchletsigns = function
   | None ->
-      Array.make n []
+      Array.make (Array.length branchletsigns) []
   | 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
+      let names = fix_empty_or_and_pattern (Array.length branchletsigns) names in
+      get_and_check_or_and_pattern_gen check_and loc names branchletsigns
 
-let compute_construtor_signatures isrec ((_,k as ity),u) =
+let compute_induction_names = compute_induction_names_gen true
+
+(* Compute the let-in signature of case analysis or standard induction scheme *)
+let compute_constructor_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 Declareops.dest_recarg recarg with
-	  | Norec | Imbr _  -> false
-	  | Mrec (_,j)  -> isrec && Int.equal j k
-	in b :: (analrec c rest)
-    | LetIn (_,_,_,c), rest -> false :: (analrec c rest)
+        let rest = analrec c rest in
+        begin match Declareops.dest_recarg recarg with
+        | Norec | Imbr _  -> true :: rest
+        | Mrec (_,j)  ->
+            if isrec && Int.equal j k then true :: true :: rest
+            else true :: rest
+        end
+    | LetIn (_,_,_,c), rest -> false :: analrec c rest
     | _, [] -> []
-    | _ -> anomaly (Pp.str "compute_construtor_signatures")
+    | _ -> anomaly (Pp.str "compute_constructor_signatures")
   in
   let (mib,mip) = Global.lookup_inductive ity in
   let n = mib.mind_nparams in
@@ -225,60 +270,28 @@ let gl_make_elim ind gl =
     pf_apply Evd.fresh_global gl gr
 
 let gl_make_case_dep ind gl =
-  pf_apply Indrec.build_case_analysis_scheme gl ind true
+  let sigma = Sigma.Unsafe.of_evar_map (Tacmach.project gl) in
+  let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma ind true
     (elimination_sort_of_goal gl)
+  in
+  (Sigma.to_evar_map sigma, r)
 
 let gl_make_case_nodep ind gl =
-  pf_apply Indrec.build_case_analysis_scheme gl ind false
+  let sigma = Sigma.Unsafe.of_evar_map (Tacmach.project gl) in
+  let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma ind false
     (elimination_sort_of_goal gl)
+  in
+  (Sigma.to_evar_map sigma, r)
 
 let make_elim_branch_assumptions ba gl =
-  let rec makerec (assums,cargs,constargs,recargs,indargs) lb lc =
-    match lb,lc with
-      | ([], _) ->
-          { ba = ba;
-            assums    = assums}
-      | ((true::tl), ((idrec,_,_ as recarg)::(idind,_,_ as indarg)::idtl)) ->
-	  makerec (recarg::indarg::assums,
-		   idrec::cargs,
-		   idrec::recargs,
-		   constargs,
-		   idind::indargs) tl idtl
-      | ((false::tl), ((id,_,_ as constarg)::idtl))      ->
-	  makerec (constarg::assums,
-		   id::cargs,
-		   id::constargs,
-		   recargs,
-		   indargs) tl idtl
-      | (_, _) -> anomaly (Pp.str "make_elim_branch_assumptions")
-  in
-  makerec ([],[],[],[],[]) ba.branchsign
-    (try List.firstn ba.nassums (pf_hyps gl)
-     with Failure _ -> anomaly (Pp.str "make_elim_branch_assumptions"))
+  let assums =
+    try List.rev (List.firstn ba.nassums (pf_hyps gl))
+    with Failure _ -> anomaly (Pp.str "make_elim_branch_assumptions") in
+  { ba = ba; assums = assums }
 
 let elim_on_ba tac ba gl = tac (make_elim_branch_assumptions ba gl) gl
 
-let make_case_branch_assumptions ba gl =
-  let rec makerec (assums,cargs,constargs,recargs) p_0 p_1 =
-    match p_0,p_1 with
-      | ([], _) ->
-          { ba = ba;
-            assums    = assums}
-      | ((true::tl), ((idrec,_,_ as recarg)::idtl)) ->
-	  makerec (recarg::assums,
-		   idrec::cargs,
-		   idrec::recargs,
-		   constargs) tl idtl
-      | ((false::tl), ((id,_,_ as constarg)::idtl)) ->
-	  makerec (constarg::assums,
-		   id::cargs,
-		   recargs,
-		   id::constargs) tl idtl
-      | (_, _) -> anomaly (Pp.str "make_case_branch_assumptions")
-  in
-  makerec ([],[],[],[]) ba.branchsign
-    (try List.firstn ba.nassums (pf_hyps gl)
-     with Failure _ -> anomaly (Pp.str "make_case_branch_assumptions"))
+let make_case_branch_assumptions = make_elim_branch_assumptions
 
 let case_on_ba tac ba gl = tac (make_case_branch_assumptions ba gl) gl
 
@@ -309,7 +322,7 @@ module New = struct
     try
       Refiner.catch_failerror e;
       tclUNIT ()
-    with e -> tclZERO e
+    with e when CErrors.noncritical e -> tclZERO e
 
   (* spiwack: I chose to give the Ltac + the same semantics as
      [Proofview.tclOR], however, for consistency with the or-else
@@ -463,6 +476,13 @@ module New = struct
   let tclPROGRESS t =
     Proofview.tclINDEPENDENT (Proofview.tclPROGRESS t)
 
+  (* Select a subset of the goals *)
+  let tclSELECT = function
+    | Tacexpr.SelectNth i -> Proofview.tclFOCUS i i
+    | Tacexpr.SelectList l -> Proofview.tclFOCUSLIST l
+    | Tacexpr.SelectId id -> Proofview.tclFOCUSID id
+    | Tacexpr.SelectAll -> fun tac -> tac
+
   (* Check that holes in arguments have been resolved *)
 
   let check_evars env sigma extsigma origsigma =
@@ -501,18 +521,26 @@ module New = struct
                 try
                   let () = check_evars env sigma_final sigma sigma_initial in
                   tclUNIT x
-                with e when Errors.noncritical e ->
+                with e when CErrors.noncritical e ->
                   tclZERO e
           else
             tclUNIT x
         in
         Proofview.Unsafe.tclEVARS sigma <*> tac >>= check_evars_if
 
+  let tclDELAYEDWITHHOLES check x tac =
+    Proofview.Goal.nf_enter { enter = begin fun gl ->
+      let env = Proofview.Goal.env gl in
+      let sigma = Proofview.Goal.sigma gl in
+      let Sigma (x, sigma, _) = x.Tacexpr.delayed env sigma in
+      tclWITHHOLES check (tac x) (Sigma.to_evar_map sigma)
+    end }
+
   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)))
+        | Proofview.Timeout as e -> Proofview.tclZERO (Refiner.FailError (0,lazy (CErrors.print e)))
         | e -> Proofview.tclZERO ~info e
       end
 
@@ -523,7 +551,7 @@ module New = struct
     let hyps = Proofview.Goal.hyps gl in
     try
       List.nth hyps (m-1)
-    with Failure _ -> Errors.error "No such assumption."
+    with Failure _ -> CErrors.error "No such assumption."
 
   let nLastDecls gl n =
     try List.firstn n (Proofview.Goal.hyps gl)
@@ -532,72 +560,70 @@ module New = struct
   let nthHypId m gl =
     (** We only use [id] *)
     let gl = Proofview.Goal.assume gl in
-    let (id,_,_) = nthDecl m gl in
-    id
+    nthDecl m gl |> get_id
   let nthHyp m gl = 
     mkVar (nthHypId m gl)
 
   let onNthHypId m tac =
-    Proofview.Goal.enter begin fun gl -> tac (nthHypId m gl) end
+    Proofview.Goal.enter { enter = begin fun gl -> tac (nthHypId m gl) end }
   let onNthHyp m tac =
-    Proofview.Goal.enter begin fun gl -> tac (nthHyp m gl) end
+    Proofview.Goal.enter { 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.Goal.nf_enter { enter = begin fun gl ->
       Proofview.tclUNIT (nthDecl m gl) >>= tac
-    end
+    end }
   let onLastDecl  = onNthDecl 1
 
   let ifOnHyp pred tac1 tac2 id =
-    Proofview.Goal.nf_enter begin fun gl ->
+    Proofview.Goal.nf_enter { 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
+    end }
 
-  let onHyps find tac = Proofview.Goal.nf_enter (fun gl -> tac (find gl))
+  let onHyps find tac = Proofview.Goal.nf_enter { enter = begin fun gl -> tac (find.enter gl) end }
 
   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
+    Proofview.Goal.enter { enter = begin fun gl ->
+    let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in
+    let rem, _ = List.split_when (Id.equal id % get_id) hyps in
     tac rem
-    end
+    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 ->
+    Proofview.Goal.enter { enter = begin fun gl ->
     let hyps = Tacmach.New.pf_ids_of_hyps gl in
     tclFIRST_PROGRESS_ON tac hyps
-    end
+    end }
   let tryAllHypsAndConcl tac =
-    Proofview.Goal.enter begin fun gl ->
+    Proofview.Goal.enter { enter = begin fun gl ->
       tclFIRST_PROGRESS_ON tac (fullGoal gl)
-    end
+    end }
 
   let onClause tac cl =
-    Proofview.Goal.enter begin fun gl ->
+    Proofview.Goal.enter { enter = begin fun gl ->
     let hyps = Tacmach.New.pf_ids_of_hyps gl in
     tclMAP tac (Locusops.simple_clause_of (fun () -> hyps) cl)
-    end
+    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 ->
+    Proofview.Goal.nf_enter { enter = begin fun gl ->
     let sigma, elim = Tacmach.New.of_old (mk_elim ind) gl in
     Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma)
-    (Proofview.Goal.nf_enter begin fun gl ->
+    (Proofview.Goal.nf_enter { enter = begin fun gl ->
     let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from gl (c, t)) 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_unsafe_type_of gl elim)) gl in
@@ -621,8 +647,8 @@ module New = struct
             (str "The elimination combinator " ++ str name_elim ++ str " is unknown.")
     in
     let elimclause' = clenv_fchain ~with_univs:false indmv elimclause indclause in
-    let branchsigns = compute_construtor_signatures isrec ind in
-    let brnames = compute_induction_names (Array.length branchsigns) allnames in
+    let branchsigns = compute_constructor_signatures isrec ind in
+    let brnames = compute_induction_names_gen false branchsigns allnames in
     let flags = Unification.elim_flags () in
     let elimclause' =
       match predicate with
@@ -634,10 +660,7 @@ module New = struct
       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);
+                 nassums = List.length branchsigns.(i);
                  branchnum = i+1;
                  ity = ind;
                  largs = List.map (clenv_nf_meta clenv') largs;
@@ -649,10 +672,10 @@ module New = struct
     Proofview.tclTHEN
       (Clenvtac.clenv_refine false clenv')
       (Proofview.tclEXTEND [] tclIDTAC branchtacs)
-    end) end
+    end }) end }
 
   let elimination_then tac c =
-    Proofview.Goal.nf_enter begin fun gl ->
+    Proofview.Goal.nf_enter { enter = begin fun gl ->
     let (ind,t) = pf_reduce_to_quantified_ind gl (pf_unsafe_type_of gl c) in
     let isrec,mkelim =
       match (Global.lookup_mind (fst (fst ind))).mind_record with
@@ -660,7 +683,7 @@ module New = struct
       | Some _ -> false,gl_make_case_dep
     in
     general_elim_then_using mkelim isrec None tac None ind (c, t)
-    end
+    end }
 
   let case_then_using =
     general_elim_then_using gl_make_case_dep false
@@ -669,16 +692,16 @@ module New = struct
     general_elim_then_using gl_make_case_nodep false
 
   let elim_on_ba tac ba =
-    Proofview.Goal.nf_enter begin fun gl ->
+    Proofview.Goal.nf_enter { enter = begin fun gl ->
     let branches = Tacmach.New.of_old (make_elim_branch_assumptions ba) gl in
     tac branches
-    end
+    end }
 
   let case_on_ba tac ba = 
-    Proofview.Goal.nf_enter begin fun gl ->
+    Proofview.Goal.nf_enter { enter = begin fun gl ->
     let branches = Tacmach.New.of_old (make_case_branch_assumptions ba) gl in
     tac branches
-    end
+    end }
 
   let elimination_sort_of_goal gl =
     (** Retyping will expand evars anyway. *)
@@ -695,11 +718,11 @@ module New = struct
   | Some id -> elimination_sort_of_hyp id gl
 
   let pf_constr_of_global ref tac =
-    Proofview.Goal.nf_enter begin fun gl ->
+    Proofview.Goal.nf_enter { enter = begin fun gl ->
       let env = Proofview.Goal.env gl in
-      let sigma = Proofview.Goal.sigma gl in
+      let sigma = Tacmach.New.project gl in
       let (sigma, c) = Evd.fresh_global env sigma ref in
       Proofview.Unsafe.tclEVARS sigma <*> (tac c)
-    end
+    end }
 
 end
diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli
index 1b3b04d9..cfdc2cff 100644
--- a/tactics/tacticals.mli
+++ b/tactics/tacticals.mli
@@ -9,7 +9,6 @@
 open Pp
 open Names
 open Term
-open Context
 open Tacmach
 open Proof_type
 open Tacexpr
@@ -60,29 +59,29 @@ val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic
 
 val onNthHypId       : int -> (Id.t -> tactic) -> tactic
 val onNthHyp         : int -> (constr -> tactic) -> tactic
-val onNthDecl        : int -> (named_declaration -> tactic) -> tactic
+val onNthDecl        : int -> (Context.Named.Declaration.t -> tactic) -> tactic
 val onLastHypId      : (Id.t -> tactic) -> tactic
 val onLastHyp        : (constr -> tactic) -> tactic
-val onLastDecl       : (named_declaration -> tactic) -> tactic
+val onLastDecl       : (Context.Named.Declaration.t -> 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 onNLastDecls     : int -> (Context.Named.t -> tactic) -> tactic
 
 val lastHypId   : goal sigma -> Id.t
 val lastHyp     : goal sigma -> constr
-val lastDecl    : goal sigma -> named_declaration
+val lastDecl    : goal sigma -> Context.Named.Declaration.t
 val nLastHypsId : int -> goal sigma -> Id.t list
 val nLastHyps   : int -> goal sigma -> constr list
-val nLastDecls  : int -> goal sigma -> named_context
+val nLastDecls  : int -> goal sigma -> Context.Named.t
 
-val afterHyp    : Id.t -> goal sigma -> named_context
+val afterHyp    : Id.t -> goal sigma -> Context.Named.t
 
 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
+val onHyps      : (goal sigma -> Context.Named.t) ->
+                  (Context.Named.t -> tactic) -> tactic
 
 (** {6 Tacticals applying to goal components } *)
 
@@ -99,32 +98,36 @@ val onClauseLR : (Id.t option -> tactic) -> clause -> tactic
 (** {6 Elimination tacticals. } *)
 
 type branch_args = {
-  ity        : pinductive;   (** 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 *)
+  nassums    : int;         (** number of assumptions/letin to be introduced *)
   branchsign : bool list;   (** the signature of the branch.
-                               true=recursive argument, false=constant *)
+                                true=assumption, false=let-in *)
   branchnames : intro_patterns}
 
 type branch_assumptions = {
-  ba        : branch_args;     (** the branch args *)
-  assums    : named_context}   (** the list of assumptions introduced *)
+  ba        : branch_args;       (** the branch args *)
+  assums    : Context.Named.t}   (** the list of assumptions introduced *)
 
-(** [check_disjunctive_pattern_size loc pats n] returns an appropriate 
-   error message if |pats| <> n *)
-val check_or_and_pattern_size :
-  Loc.t -> delayed_open_constr or_and_intro_pattern_expr -> int -> unit
+(** [get_and_check_or_and_pattern loc pats branchsign] returns an appropriate
+   error message if |pats| <> |branchsign|; extends them if no pattern is given
+   for let-ins in the case of a conjunctive pattern *)
+val get_and_check_or_and_pattern :
+  Loc.t -> delayed_open_constr or_and_intro_pattern_expr ->
+  bool list array -> intro_patterns array
 
 (** Tolerate "[]" to mean a disjunctive pattern of any length *)
 val fix_empty_or_and_pattern : int -> 
   delayed_open_constr or_and_intro_pattern_expr ->
   delayed_open_constr or_and_intro_pattern_expr
 
+val compute_constructor_signatures : rec_flag -> pinductive -> bool list array
+
 (** Useful for [as intro_pattern] modifier *)
 val compute_induction_names :
-  int -> or_and_intro_pattern option -> intro_patterns array
+  bool list array -> or_and_intro_pattern option -> intro_patterns array
 
 val elimination_sort_of_goal : goal sigma -> sorts_family
 val elimination_sort_of_hyp  : Id.t -> goal sigma -> sorts_family
@@ -144,7 +147,7 @@ val case_on_ba : (branch_assumptions -> tactic) -> branch_args  -> tactic
     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
+    particular [Tacticals.New.tclORELSE] sees lack 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
@@ -218,12 +221,14 @@ module New : sig
   val tclCOMPLETE : 'a tactic -> 'a tactic
   val tclSOLVE : unit tactic list -> unit tactic
   val tclPROGRESS : unit tactic -> unit tactic
+  val tclSELECT : goal_selector -> 'a tactic -> 'a tactic
   val tclWITHHOLES : bool -> 'a tactic -> Evd.evar_map -> 'a tactic
+  val tclDELAYEDWITHHOLES : bool -> 'a delayed_open -> ('a -> unit tactic) -> 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 nLastDecls  : ([ `NF ], 'r) Proofview.Goal.t -> int -> Context.Named.t
 
   val ifOnHyp     : (identifier * types -> bool) ->
     (identifier -> unit Proofview.tactic) -> (identifier -> unit Proofview.tactic) ->
@@ -232,19 +237,19 @@ module New : sig
   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 onLastDecl       : (Context.Named.Declaration.t -> 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 onHyps      : ([ `NF ], Context.Named.t) Proofview.Goal.enter ->
+                    (Context.Named.t -> unit tactic) -> unit tactic
+  val afterHyp    : Id.t -> (Context.Named.t -> 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_sort_of_goal : ('a, 'r) Proofview.Goal.t -> sorts_family
+  val elimination_sort_of_hyp  : Id.t -> ('a, 'r) Proofview.Goal.t -> sorts_family
+  val elimination_sort_of_clause : Id.t option -> ('a, 'r) Proofview.Goal.t -> sorts_family
 
   val elimination_then :
     (branch_args -> unit Proofview.tactic) ->
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index f23808f6..9d64e7c5 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -7,13 +7,12 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Nameops
 open Term
 open Vars
-open Context
 open Termops
 open Find_subterm
 open Namegen
@@ -26,7 +25,7 @@ open Evd
 open Pfedit
 open Tacred
 open Genredexpr
-open Tacmach
+open Tacmach.New
 open Logic
 open Clenv
 open Refiner
@@ -43,21 +42,17 @@ open Locus
 open Locusops
 open Misctypes
 open Proofview.Notations
-
-let nb_prod x =
-  let rec count n c =
-    match kind_of_term c with
-        Prod(_,_,t) -> count (n+1) t
-      | LetIn(_,a,_,t) -> count n (subst1 a t)
-      | Cast(c,_,_) -> count n c
-      | _ -> n
-  in count 0 x
+open Sigma.Notations
 
 let inj_with_occurrences e = (AllOccurrences,e)
 
 let dloc = Loc.ghost
 
-let typ_of = Retyping.get_type_of
+let typ_of env sigma c =
+  let open Retyping in
+  try get_type_of ~lax:true env (Sigma.to_evar_map sigma) c
+  with RetypeError e ->
+    user_err_loc (Loc.ghost, "", print_retype_error e)
 
 open Goptions
 
@@ -88,7 +83,7 @@ let _ =
 
 let apply_solve_class_goals = ref (false)
 let _ = Goptions.declare_bool_option {
-  Goptions.optsync = true; Goptions.optdepr = false;
+  Goptions.optsync = true; Goptions.optdepr = true;
   Goptions.optname =
     "Perform typeclass resolution on apply-generated subgoals.";
   Goptions.optkey = ["Typeclass";"Resolution";"After";"Apply"];
@@ -126,13 +121,26 @@ let _ =
       optread  = (fun () -> !universal_lemma_under_conjunctions) ;
       optwrite = (fun b -> universal_lemma_under_conjunctions := b) }
 
+(* Shrinking of abstract proofs. *)
+
+let shrink_abstract = ref true
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = true;
+      optname  = "shrinking of abstracted proofs";
+      optkey   = ["Shrink"; "Abstract"];
+      optread  = (fun () -> !shrink_abstract) ;
+      optwrite = (fun b -> shrink_abstract := b) }
+
 (* 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 = ref false
+let bracketing_last_or_and_intro_pattern = ref true
 
 let use_bracketing_last_or_and_intro_pattern () =
   !bracketing_last_or_and_intro_pattern
@@ -144,7 +152,7 @@ let _ =
       optdepr  = false;
       optname  = "bracketing last or-and introduction pattern";
       optkey   = ["Bracketing";"Last";"Introduction";"Pattern"];
-      optread  = (fun () -> !bracketing_last_or_and_intro_pattern) ;
+      optread  = (fun () -> !bracketing_last_or_and_intro_pattern);
       optwrite = (fun b -> bracketing_last_or_and_intro_pattern := b) }
 
 (*********************************************)
@@ -157,71 +165,77 @@ let _ =
 
 (** 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 unsafe_intro env store decl b =
+  let open Context.Named.Declaration in
+  Refine.refine ~unsafe:true { run = 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 nctx = push_named_context_val decl ctx in
+    let inst = List.map (mkVar % get_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 ~principal:true ~store ninst in
-    sigma, mkNamedLambda_or_LetIn (id, c, t) ev
-  end
+    let nb = subst1 (mkVar (get_id decl)) b in
+    let Sigma (ev, sigma, p) = new_evar_instance nctx sigma nb ~principal:true ~store ninst in
+    Sigma (mkNamedLambda_or_LetIn decl ev, sigma, p)
+  end }
 
 let introduction ?(check=true) id =
-  Proofview.Goal.enter begin fun gl ->
+  let open Context.Named.Declaration in
+  Proofview.Goal.enter { 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 sigma = Tacmach.New.project gl in
+    let hyps = named_context_val (Proofview.Goal.env 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
+    let () = if check && mem_named_context_val id hyps then
       errorlabstrm "Tactics.introduction"
         (str "Variable " ++ pr_id id ++ str " 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
+    | Prod (_, t, b) -> unsafe_intro env store (LocalAssum (id, t)) b
+    | LetIn (_, c, t, b) -> unsafe_intro env store (LocalDef (id, c, t)) b
     | _ -> raise (RefinerError IntroNeedsProduct)
-  end
+  end }
 
 let refine          = Tacmach.refine
 
 let convert_concl ?(check=true) ty k =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { 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 =
+    Refine.refine ~unsafe:true { run = begin fun sigma ->
+      let Sigma ((), sigma, p) =
         if check then begin
+          let sigma = Sigma.to_evar_map sigma in
           ignore (Typing.unsafe_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
+          Sigma.Unsafe.of_pair ((), sigma)
+        end else Sigma.here () sigma in
+      let Sigma (x, sigma, q) = Evarutil.new_evar env sigma ~principal:true ~store ty in
+      let ans = if k == DEFAULTcast then x else mkCast(x,k,conclty) in
+      Sigma (ans, sigma, p +> q)
+    end }
+  end }
 
 let convert_hyp ?(check=true) d =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
     let env = Proofview.Goal.env gl in
-    let sigma = Proofview.Goal.sigma gl in
+    let sigma = Tacmach.New.project 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
+    Refine.refine ~unsafe:true { run = begin fun sigma ->
+      Evarutil.new_evar env sigma ~principal:true ~store ty
+    end }
+  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 ->
+  Proofview.Goal.enter { enter = begin fun gl ->
     try
       let sigma, b = Tacmach.New.pf_apply (Reductionops.infer_conv ~pb) gl x y in
       if b then Proofview.Unsafe.tclEVARS sigma
@@ -229,7 +243,7 @@ let convert_gen pb x y =
     with (* Reduction.NotConvertible *) _ ->
       (** FIXME: Sometimes an anomaly is raised from conversion *)
       Tacticals.New.tclFAIL 0 (str "Not convertible")
-end
+end }
 
 let convert x y = convert_gen Reduction.CONV x y
 let convert_leq x y = convert_gen Reduction.CUMUL x y
@@ -261,32 +275,64 @@ let replacing_dependency_msg env sigma id = function
 let error_replacing_dependency env sigma id err =
   errorlabstrm "" (replacing_dependency_msg env sigma id err)
 
-let thin l gl =
-  try thin l gl
-  with Evarutil.ClearDependencyError (id,err) ->
-    error_clear_dependency (pf_env gl) (project gl) id err
+(* This tactic enables the user to remove hypotheses from the signature.
+ * Some care is taken to prevent him from removing variables that are
+ * subsequently used in other hypotheses or in the conclusion of the
+ * goal. *)
 
-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 clear_gen fail = function
+| [] -> Proofview.tclUNIT ()
+| ids ->
+  Proofview.Goal.s_enter { s_enter = begin fun gl ->
+    let ids = List.fold_right Id.Set.add ids Id.Set.empty in
+    (** clear_hyps_in_evi does not require nf terms *)
+    let gl = Proofview.Goal.assume gl in
+    let env = Proofview.Goal.env gl in
+    let sigma = Tacmach.New.project gl in
+    let concl = Proofview.Goal.concl gl in
+    let evdref = ref sigma in
+    let (hyps, concl) =
+      try clear_hyps_in_evi env evdref (named_context_val env) concl ids
+      with Evarutil.ClearDependencyError (id,err) -> fail env sigma id err
+    in
+    let env = reset_with_named_context hyps env in
+    let tac = Refine.refine ~unsafe:true { run = fun sigma ->
+      Evarutil.new_evar env sigma ~principal:true concl
+    } in
+    Sigma.Unsafe.of_pair (tac, !evdref)
+  end }
+
+let clear ids = clear_gen error_clear_dependency ids
+let clear_for_replacing ids = clear_gen error_replacing_dependency ids
 
 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
+  let doclear = match clear_flag with
     | None -> dft && isVar c
     | Some true -> check_isvar c; true
     | Some false -> false in
-  if clear then Proofview.V82.tactic (thin [destVar c])
+  if doclear then clear [destVar c]
   else Tacticals.New.tclIDTAC
 
 (* Moving hypotheses *)
-let move_hyp id dest gl = Tacmach.move_hyp id dest gl
+let move_hyp id dest =
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let ty = Proofview.Goal.raw_concl gl in
+    let store = Proofview.Goal.extra gl in
+    let sign = named_context_val env in
+    let sign' = move_hyp_in_named_context id dest sign in
+    let env = reset_with_named_context sign' env in
+    Refine.refine ~unsafe:true { run = begin fun sigma ->
+      Evarutil.new_evar env sigma ~principal:true ~store ty
+    end }
+  end }
 
 (* Renaming hypotheses *)
 let rename_hyp repl =
+  let open Context.Named.Declaration in
   let fold accu (src, dst) = match accu with
   | None -> None
   | Some (srcs, dsts) ->
@@ -302,13 +348,13 @@ let rename_hyp repl =
   match dom with
   | None -> Tacticals.New.tclZEROMSG (str "Not a one-to-one name mapping")
   | Some (src, dst) ->
-    Proofview.Goal.enter begin fun gl ->
+    Proofview.Goal.enter { 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 fold accu decl = Id.Set.add (get_id decl) accu in
       let vars = List.fold_left fold Id.Set.empty hyps in
       let () =
         if not (Id.Set.subset src vars) then
@@ -319,25 +365,25 @@ let rename_hyp repl =
       let () =
         try
           let elt = Id.Set.choose (Id.Set.inter dst mods) in
-          Errors.errorlabstrm "" (pr_id elt ++ str " is already used")
+          CErrors.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)
+      let map decl =
+        decl |> map_id (fun id -> try List.assoc_f Id.equal id repl with Not_found -> id)
+             |> map_constr subst
       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
+      let instance = List.map (mkVar % get_id) hyps in
+      Refine.refine ~unsafe:true { run = begin fun sigma ->
+        Evarutil.new_evar_instance nctx sigma nconcl ~principal:true ~store instance
+      end }
+    end }
 
 (**************************************************************)
 (*          Fresh names                                       *)
@@ -359,11 +405,13 @@ let id_of_name_with_default id = function
 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 default_id env sigma decl =
+  let open Context.Rel.Declaration in
+  match decl with
+  | LocalAssum (name,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
+  | LocalDef (name,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
@@ -382,7 +430,7 @@ 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
+      let sigma = Tacmach.New.project gl in
       new_fresh_id idl (default_id env sigma decl) gl
   | NamingBasedOn (id,idl) ->  new_fresh_id idl id gl
   | NamingMustBe (loc,id) ->
@@ -398,16 +446,17 @@ let find_name mayrepl decl naming gl = match naming with
 (**************************************************************)
 
 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
+  let open Context.Rel.Declaration in
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let id = find_name b (LocalAssum (Anonymous,t)) naming gl in
     Tacticals.New.tclTHENLAST
       (Proofview.V82.tactic
          (fun gl ->
-           try internal_cut b id t gl
+           try Tacmach.internal_cut b id t gl
            with Evarutil.ClearDependencyError (id,err) ->
              error_replacing_dependency (pf_env gl) (project gl) id err))
       (tac id)
-  end
+  end }
 
 let assert_before_gen b naming t =
   assert_before_then_gen b naming t (fun _ -> Proofview.tclUNIT ())
@@ -416,16 +465,17 @@ 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
+  let open Context.Rel.Declaration in
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let id = find_name b (LocalAssum (Anonymous,t)) naming gl in
     Tacticals.New.tclTHENFIRST
       (Proofview.V82.tactic
          (fun gl ->
-           try internal_cut_rev b id t gl
+           try Tacmach.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
+  end }
 
 let assert_after_gen b naming t =
   assert_after_then_gen b naming t (fun _ -> (Proofview.tclUNIT ()))
@@ -437,23 +487,120 @@ let assert_after_replacing id = assert_after_gen true (NamingMustBe (dloc,id))
 (*          Fixpoints and CoFixpoints                         *)
 (**************************************************************)
 
-(* Refine as a fixpoint *)
-let mutual_fix = Tacmach.mutual_fix
+let rec mk_holes : type r s. _ -> r Sigma.t -> (s, r) Sigma.le -> _ -> (_, s) Sigma.sigma =
+fun env sigma p -> function
+| [] -> Sigma ([], sigma, p)
+| arg :: rem ->
+  let Sigma (arg, sigma, q) = Evarutil.new_evar env sigma arg in
+  let Sigma (rem, sigma, r) = mk_holes env sigma (p +> q) rem in
+  Sigma (arg :: rem, sigma, r)
+
+let rec check_mutind env sigma k cl = match kind_of_term (strip_outer_cast cl) with
+| Prod (na, c1, b) ->
+  if Int.equal k 1 then
+    try
+      let ((sp, _), u), _ = find_inductive env sigma c1 in
+      (sp, u)
+    with Not_found -> error "Cannot do a fixpoint on a non inductive type."
+  else
+    let open Context.Rel.Declaration in
+    check_mutind (push_rel (LocalAssum (na, c1)) env) sigma (pred k) b
+| _ -> error "Not enough products."
 
-let fix ido n gl = match ido with
+(* Refine as a fixpoint *)
+let mutual_fix f n rest j = Proofview.Goal.nf_enter { enter = begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Tacmach.New.project gl in
+  let concl = Proofview.Goal.concl gl in
+  let (sp, u) = check_mutind env sigma n concl in
+  let firsts, lasts = List.chop j rest in
+  let all = firsts @ (f, n, concl) :: lasts in
+  let rec mk_sign sign = function
+  | [] -> sign
+  | (f, n, ar) :: oth ->
+    let open Context.Named.Declaration in
+    let (sp', u')  = check_mutind env sigma n ar in
+    if not (eq_mind sp sp') then
+      error "Fixpoints should be on the same mutual inductive declaration.";
+    if mem_named_context_val f sign then
+      errorlabstrm "Logic.prim_refiner"
+        (str "Name " ++ pr_id f ++ str " already used in the environment");
+    mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth
+  in
+  let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in
+  Refine.refine { run = begin fun sigma ->
+    let Sigma (evs, sigma, p) = mk_holes nenv sigma Sigma.refl (List.map pi3 all) in
+    let ids = List.map pi1 all 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
+    let bodies = Array.of_list evs in
+    let oterm = Term.mkFix ((indxs,0),(funnames,typarray,bodies)) in
+    Sigma (oterm, sigma, p)
+  end }
+end }
+
+let fix ido n = match ido with
   | None ->
-      mutual_fix (fresh_id [] (Pfedit.get_current_proof_name ()) gl) n [] 0 gl
+    Proofview.Goal.enter { enter = begin fun gl ->
+      let name = Pfedit.get_current_proof_name () in
+      let id = new_fresh_id [] name gl in
+      mutual_fix id n [] 0
+    end }
   | Some id ->
-      mutual_fix id n [] 0 gl
+    mutual_fix id n [] 0
+
+let rec check_is_mutcoind env sigma cl =
+  let b = whd_all env sigma cl in
+  match kind_of_term b with
+  | Prod (na, c1, b) ->
+    let open Context.Rel.Declaration in
+    check_is_mutcoind (push_rel (LocalAssum (na,c1)) env) sigma b
+  | _ ->
+    try
+      let _ = find_coinductive env sigma b in ()
+    with Not_found ->
+      error "All methods must construct elements in coinductive types."
 
 (* Refine as a cofixpoint *)
-let mutual_cofix = Tacmach.mutual_cofix
-
-let cofix ido gl = match ido with
+let mutual_cofix f others j = Proofview.Goal.nf_enter { enter = begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Tacmach.New.project gl in
+  let concl = Proofview.Goal.concl gl in
+  let firsts,lasts = List.chop j others in
+  let all = firsts @ (f, concl) :: lasts in
+  List.iter (fun (_, c) -> check_is_mutcoind env sigma c) all;
+  let rec mk_sign sign = function
+  | [] -> sign
+  | (f, ar) :: oth ->
+    let open Context.Named.Declaration in
+    if mem_named_context_val f sign then
+      error "Name already used in the environment.";
+    mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth
+  in
+  let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in
+  Refine.refine { run = begin fun sigma ->
+    let (ids, types) = List.split all in
+    let Sigma (evs, sigma, p) = mk_holes nenv sigma Sigma.refl types 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
+    let oterm = Term.mkCoFix (0, (funnames, typarray, bodies)) in
+    Sigma (oterm, sigma, p)
+  end }
+end }
+
+let cofix ido = match ido with
   | None ->
-      mutual_cofix (fresh_id [] (Pfedit.get_current_proof_name ()) gl) [] 0 gl
+    Proofview.Goal.enter { enter = begin fun gl ->
+      let name = Pfedit.get_current_proof_name () in
+      let id = new_fresh_id [] name gl in
+      mutual_cofix id [] 0
+    end }
   | Some id ->
-      mutual_cofix id [] 0 gl
+      mutual_cofix id [] 0
 
 (**************************************************************)
 (*          Reduction and conversion tactics                  *)
@@ -461,17 +608,18 @@ let cofix ido gl = match ido with
 
 type tactic_reduction = env -> evar_map -> constr -> constr
 
-let pf_reduce_decl redfun where (id,c,ty) gl =
-  let redfun' = pf_reduce redfun gl in
-  match c with
-  | None ->
+let pf_reduce_decl redfun where decl gl =
+  let open Context.Named.Declaration in
+  let redfun' = Tacmach.New.pf_apply redfun gl in
+  match decl with
+  | LocalAssum (id,ty) ->
       if where == InHypValueOnly then
 	errorlabstrm "" (pr_id id ++ str " has no value.");
-      (id,None,redfun' ty)
-  | Some b ->
+      LocalAssum (id,redfun' ty)
+  | LocalDef (id,b,ty) ->
       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')
+      LocalDef (id,b',ty')
 
 (* Possibly equip a reduction with the occurrences mentioned in an
    occurrence clause *)
@@ -541,12 +689,15 @@ let bind_red_expr_occurrences occs nbcl redexp =
    reduction function either to the conclusion or to a
    certain hypothesis *)
 
-let reduct_in_concl (redfun,sty) gl =
-  Proofview.V82.of_tactic (convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) sty) gl
+let reduct_in_concl (redfun,sty) =
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
+    convert_concl_no_check (Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl)) sty
+  end }
 
-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 reduct_in_hyp ?(check=false) redfun (id,where) =
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
+  convert_hyp ~check (pf_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl)
+  end }
 
 let revert_cast (redfun,kind as r) =
   if kind == DEFAULTcast then (redfun,REVERTcast) else r
@@ -557,78 +708,77 @@ let reduct_option ?(check=false) redfun = function
 
 (** 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 ->
+let pf_e_reduce_decl redfun where decl gl =
+  let open Context.Named.Declaration in
+  let sigma = Proofview.Goal.sigma gl in
+  let redfun sigma c = redfun.e_redfun (Tacmach.New.pf_env gl) sigma c in
+  match decl with
+  | LocalAssum (id,ty) ->
       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 Sigma (ty', sigma, p) = redfun sigma ty in
+    Sigma (LocalAssum (id, ty'), sigma, p)
+  | LocalDef (id,b,ty) ->
+      let Sigma (b', sigma, p) = if where != InHypTypeOnly then redfun sigma b else Sigma.here b sigma in
+      let Sigma (ty', sigma, q) = if where != InHypValueOnly then redfun sigma ty else Sigma.here ty sigma in
+      Sigma (LocalDef (id, b', ty'), sigma, p +> q)
+
+let e_reduct_in_concl ~check (redfun, sty) =
+  Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let Sigma (c', sigma, p) = redfun.e_redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in
+    Sigma (convert_concl ~check c' sty, sigma, p)
+  end }
+
+let e_reduct_in_hyp ?(check=false) redfun (id, where) =
+  Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
+    let Sigma (decl', sigma, p) = pf_e_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl in
+    Sigma (convert_hyp ~check decl', sigma, p)
+  end }
 
 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)
+  | None    -> e_reduct_in_concl ~check (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 ->
+  Proofview.Goal.s_enter { s_enter = begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let Sigma (c, sigma, p) = redfun.e_redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.raw_concl gl) in
+    Sigma (convert_concl_no_check c sty, sigma, p)
+  end }
+
+let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigma =
+  let open Context.Named.Declaration in
+  match decl with
+  | LocalAssum (id,ty) ->
       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 
+    let Sigma (ty', sigma, p) = (redfun false).e_redfun env sigma ty in
+    Sigma (LocalAssum (id, ty'), sigma, p)
+  | LocalDef (id,b,ty) ->
+      let Sigma (b', sigma, p) =
+	if where != InHypTypeOnly then (redfun true).e_redfun env sigma b else Sigma.here b sigma
       in
-      let sigma',ty' = 
-	if where != InHypValueOnly then redfun false env sigma' ty else sigma', ty 
+      let Sigma (ty', sigma, q) =
+	if where != InHypValueOnly then (redfun false).e_redfun env sigma ty else Sigma.here ty sigma
       in
-	sigma', (id,Some b',ty')
+      Sigma (LocalDef (id,b',ty'), sigma, p +> q)
 
 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
+  Proofview.Goal.s_enter { s_enter = begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let hyp = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in
+    let Sigma (c, sigma, p) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in
+    Sigma (convert_hyp c, sigma, p)
+  end }
 
-type change_arg = Pattern.patvar_map -> evar_map -> evar_map * constr
+type change_arg = Pattern.patvar_map -> constr Sigma.run
 
-let make_change_arg c =
-  fun pats sigma -> (sigma, replace_vars (Id.Map.bindings pats) c)
+let make_change_arg c pats =
+  { run = fun sigma -> Sigma.here (replace_vars (Id.Map.bindings pats) c) sigma }
 
 let check_types env sigma mayneedglobalcheck deep newc origc =
   let t1 = Retyping.get_type_of env sigma newc in
@@ -639,43 +789,46 @@ let check_types env sigma mayneedglobalcheck deep newc origc =
     let sigma, b = infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 in
     if not b then
       if
-        isSort (whd_betadeltaiota env sigma t1) &&
-        isSort (whd_betadeltaiota env sigma t2)
+        isSort (whd_all env sigma t1) &&
+        isSort (whd_all env sigma t2)
       then (mayneedglobalcheck := true; sigma)
       else
         errorlabstrm "convert-check-hyp" (str "Types are incompatible.")
     else sigma
   end
   else
-    if not (isSort (whd_betadeltaiota env sigma t1)) then
+    if not (isSort (whd_all env sigma t1)) then
       errorlabstrm "convert-check-hyp" (str "Not a type.")
     else sigma
 
 (* 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
+let change_and_check cv_pb mayneedglobalcheck deep t = { e_redfun = begin fun env sigma c ->
+  let Sigma (t', sigma, p) = t.run sigma in
+  let sigma = Sigma.to_evar_map sigma in
   let sigma = check_types env sigma mayneedglobalcheck deep t' c in
   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'
+  Sigma.Unsafe.of_pair (t', sigma)
+end }
 
 (* Use cumulativity only if changing the conclusion not a subterm *)
-let change_on_subterm cv_pb deep t where env sigma c =
+let change_on_subterm cv_pb deep t where = { e_redfun = begin fun env sigma c ->
   let mayneedglobalcheck = ref false in
-  let sigma,c = match where with
-  | None -> change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty) env sigma c
+  let Sigma (c, sigma, p) = match where with
+  | None -> (change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty)).e_redfun env sigma c
   | Some occl ->
-      e_contextually false occl
+      (e_contextually false occl
         (fun subst ->
-          change_and_check Reduction.CONV mayneedglobalcheck true (t subst))
+          change_and_check Reduction.CONV mayneedglobalcheck true (t subst))).e_redfun
         env sigma c in
   if !mayneedglobalcheck then
     begin
-      try ignore (Typing.unsafe_type_of env sigma c)
+      try ignore (Typing.unsafe_type_of env (Sigma.to_evar_map sigma) c)
       with e when catchable_exception e ->
         error "Replacement would lead to an ill-typed term."
     end;
-  sigma,c
+  Sigma (c, sigma, p)
+end }
 
 let change_in_concl occl t =
   e_change_in_concl ((change_on_subterm Reduction.CUMUL false t occl),DEFAULTcast)
@@ -687,14 +840,16 @@ 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 (fun () -> pf_ids_of_hyps gl) cls in
-  Proofview.V82.of_tactic (Tacticals.New.tclMAP (function
+let change chg c cls =
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let cls = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cls in
+    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
+  end }
 
 let change_concl t = 
   change_in_concl None (make_change_arg t)
@@ -728,14 +883,18 @@ let reduction_clause redexp cl =
     | OnConcl occs ->
 	(None, bind_red_expr_occurrences occs nbcl redexp)) cl
 
-let reduce redexp cl goal =
-  let cl = concrete_clause_of (fun () -> pf_ids_of_hyps goal) cl in
-  let redexps = reduction_clause redexp cl in
+let reduce redexp cl =
+  let trace () = Pp.(hov 2 (Pptactic.pr_atomic_tactic (Global.env()) (TacReduce (redexp,cl)))) in
+  Proofview.Trace.name_tactic trace begin
+  Proofview.Goal.enter { enter = begin fun gl ->
+  let cl' = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in
+  let redexps = reduction_clause redexp cl' in
   let check = match redexp with Fold _ | Pattern _ -> true | _ -> false in
-  let tac = tclMAP (fun (where,redexp) ->
+  Tacticals.New.tclMAP (fun (where,redexp) ->
     e_reduct_option ~check
-      (Redexpr.reduction_of_red_expr (pf_env goal) redexp) where) redexps in
-  if check then with_check tac goal else tac goal
+      (Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp) where) redexps
+  end }
+  end
 
 (* Unfolding occurrences of a constant *)
 
@@ -756,10 +915,9 @@ let unfold_constr = function
 let find_intro_names ctxt gl =
   let _, res = List.fold_right
     (fun decl acc ->
-      let wantedname,x,typdecl = decl in
       let env,idl = acc in
       let name = fresh_id idl (default_id env gl.sigma decl) gl in
-      let newenv = push_rel (wantedname,x,typdecl) env in
+      let newenv = push_rel decl env in
       (newenv,(name::idl)))
     ctxt (pf_env gl , []) in
   List.rev res
@@ -767,19 +925,19 @@ let find_intro_names ctxt gl =
 let build_intro_tac id dest tac = match dest with
   | MoveLast -> Tacticals.New.tclTHEN (introduction id) (tac id)
   | dest -> Tacticals.New.tclTHENLIST 
-    [introduction id; 
-     Proofview.V82.tactic (move_hyp id dest); tac id]
-    
+    [introduction id; 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 open Context.Rel.Declaration in
+  Proofview.Goal.enter { enter = begin fun gl ->
     let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in
-    let concl = nf_evar (Proofview.Goal.sigma gl) concl in
+    let concl = nf_evar (Tacmach.New.project 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
+        let name = find_name false (LocalAssum (name,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
+        let name = find_name false (LocalDef (name,b,t)) name_flag gl in
 	build_intro_tac name move_flag tac
     | _ ->
 	begin if not force_flag then Proofview.tclZERO (RefinerError IntroNeedsProduct)
@@ -790,14 +948,14 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac =
           else Proofview.tclUNIT ()
         end <*>
 	  Proofview.tclORELSE
-	  (Tacticals.New.tclTHEN (Proofview.V82.tactic hnf_in_concl)
+	  (Tacticals.New.tclTHEN hnf_in_concl
 	     (intro_then_gen name_flag move_flag false dep_flag tac))
           begin function (e, info) -> match e with
             | RefinerError IntroNeedsProduct ->
                 Tacticals.New.tclZEROMSG (str "No product even after head-reduction.")
             | e -> Proofview.tclZERO ~info e
           end
-  end
+  end }
 
 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
@@ -842,33 +1000,36 @@ let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac =
   aux n []
 
 let get_next_hyp_position id gl =
+  let open Context.Named.Declaration in
   let rec aux = function
   | [] -> raise (RefinerError (NoSuchHyp id))
-  | (hyp,_,_) :: right ->
-    if Id.equal hyp id then
-      match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveLast
+  | decl :: right ->
+    if Id.equal (get_id decl) id then
+      match right with decl::_ -> MoveBefore (get_id decl) | [] -> MoveLast
     else
       aux right
   in
   aux (Proofview.Goal.hyps (Proofview.Goal.assume gl))
 
 let get_previous_hyp_position id gl =
+  let open Context.Named.Declaration in
   let rec aux dest = function
   | [] -> raise (RefinerError (NoSuchHyp id))
-  | (hyp,_,_) :: right ->
-    if Id.equal hyp id then dest else aux (MoveAfter hyp) right
+  | decl :: right ->
+      let hyp = get_id decl in
+      if Id.equal hyp id then dest else aux (MoveAfter hyp) right
   in
   aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl))
 
 let intro_replacing id =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
   let next_hyp = get_next_hyp_position id gl in
   Tacticals.New.tclTHENLIST [
-    Proofview.V82.tactic (thin_for_replacing [id]);
+    clear_for_replacing [id];
     introduction id;
-    Proofview.V82.tactic (move_hyp id next_hyp);
+    move_hyp id next_hyp;
   ]
-  end
+  end }
 
 (* 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''
@@ -880,47 +1041,47 @@ let intro_replacing id =
 (* the behavior of inversion *)
 let intros_possibly_replacing ids =
   let suboptimal = true in
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { 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])))
+	Tacticals.New.tclTRY (clear_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
+  end }
 
 (* This version assumes that replacement is actually possible *)
 let intros_replacing ids =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { 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))
+      (clear_for_replacing ids)
       (Tacticals.New.tclMAP (fun (id,pos) -> intro_move (Some id) pos) posl)
-  end
+  end }
 
 (* User-level introduction tactics *)
 
-let pf_lookup_hypothesis_as_renamed env ccl = function
+let lookup_hypothesis_as_renamed env ccl = function
   | AnonHyp n -> Detyping.lookup_index_as_renamed env ccl n
   | NamedHyp id -> Detyping.lookup_name_as_displayed env ccl id
 
-let pf_lookup_hypothesis_as_renamed_gen red h gl =
-  let env = pf_env gl in
+let lookup_hypothesis_as_renamed_gen red h gl =
+  let env = Proofview.Goal.env gl in
   let rec aux ccl =
-    match pf_lookup_hypothesis_as_renamed env ccl h with
+    match lookup_hypothesis_as_renamed env ccl h with
       | None when red ->
-          aux
-	    (snd ((fst (Redexpr.reduction_of_red_expr env (Red true)))
-	       env (project gl) ccl))
+        let (redfun, _) = Redexpr.reduction_of_red_expr env (Red true) in
+        let Sigma (c, _, _) = redfun.e_redfun env (Proofview.Goal.sigma gl) ccl in
+        aux c
       | x -> x
   in
-  try aux (pf_concl gl)
+  try aux (Proofview.Goal.concl gl)
   with Redelimination -> None
 
-let is_quantified_hypothesis id g =
-  match pf_lookup_hypothesis_as_renamed_gen false (NamedHyp id) g with
+let is_quantified_hypothesis id gl =
+  match lookup_hypothesis_as_renamed_gen false (NamedHyp id) gl with
     | Some _ -> true
     | None -> false
 
@@ -932,7 +1093,7 @@ let msg_quantified_hypothesis = function
       str " non dependent hypothesis"
 
 let depth_of_quantified_hypothesis red h gl =
-  match pf_lookup_hypothesis_as_renamed_gen red h gl with
+  match lookup_hypothesis_as_renamed_gen red h gl with
     | Some depth -> depth
     | None ->
         errorlabstrm "lookup_quantified_hypothesis"
@@ -942,10 +1103,10 @@ let depth_of_quantified_hypothesis red h gl =
 	  str".")
 
 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
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
+  let n = depth_of_quantified_hypothesis red h gl in
   Tacticals.New.tclDO n (if red then introf else intro)
-  end
+  end }
 
 let intros_until_id id = intros_until_gen false (NamedHyp id)
 let intros_until_n_gen red n = intros_until_gen red (AnonHyp n)
@@ -953,10 +1114,14 @@ 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 tclCHECKVAR id gl = ignore (pf_get_hyp gl id); tclIDTAC gl
+let tclCHECKVAR id =
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let _ = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in
+    Proofview.tclUNIT ()
+  end }
 
 let try_intros_until_id_check id =
-  Tacticals.New.tclORELSE (intros_until_id id) (Proofview.V82.tactic (tclCHECKVAR id))
+  Tacticals.New.tclORELSE (intros_until_id id) (tclCHECKVAR id)
 
 let try_intros_until tac = function
   | NamedHyp id -> Tacticals.New.tclTHEN (try_intros_until_id_check id) (tac id)
@@ -968,12 +1133,23 @@ let rec intros_move = function
       Tacticals.New.tclTHEN (intro_gen (NamingMustBe (dloc,hyp)) destopt false false)
 	(intros_move rest)
 
+let run_delayed env sigma c =
+  Sigma.run sigma { Sigma.run = fun sigma -> c.delayed env sigma }
+
 (* Apply a tactic on a quantified hypothesis, an hypothesis in context
    or a term with bindings *)
 
+let tactic_infer_flags with_evar = {
+  Pretyping.use_typeclasses = true;
+  Pretyping.solve_unification_constraints = true;
+  Pretyping.use_hook = Some solve_by_implicit_tactic;
+  Pretyping.fail_evar = not with_evar;
+  Pretyping.expand_evars = true }
+
+
 let onOpenInductionArg env sigma tac = function
   | clear_flag,ElimOnConstr f ->
-      let (sigma',cbl) = f env sigma in
+      let (cbl, sigma') = run_delayed env sigma f in
       let pending = (sigma,sigma') in
       Tacticals.New.tclTHEN
         (Proofview.Unsafe.tclEVARS sigma')
@@ -983,20 +1159,20 @@ let onOpenInductionArg env sigma tac = function
         (intros_until_n n)
         (Tacticals.New.onLastHyp
            (fun c ->
-             Proofview.Goal.enter begin fun gl ->
-             let sigma = Proofview.Goal.sigma gl in
+             Proofview.Goal.enter { enter = begin fun gl ->
+             let sigma = Tacmach.New.project gl in
              let pending = (sigma,sigma) in
              tac clear_flag (pending,(c,NoBindings))
-             end))
+             end }))
   | clear_flag,ElimOnIdent (_,id) ->
       (* A quantified hypothesis *)
       Tacticals.New.tclTHEN
         (try_intros_until_id_check id)
-        (Proofview.Goal.enter begin fun gl ->
-         let sigma = Proofview.Goal.sigma gl in
+        (Proofview.Goal.enter { enter = begin fun gl ->
+         let sigma = Tacmach.New.project gl in
          let pending = (sigma,sigma) in
          tac clear_flag (pending,(mkVar id,NoBindings))
-        end)
+        end })
 
 let onInductionArg tac = function
   | clear_flag,ElimOnConstr cbl ->
@@ -1011,25 +1187,42 @@ let onInductionArg tac = function
         (try_intros_until_id_check id)
         (tac clear_flag (mkVar id,NoBindings))
 
-let map_induction_arg f = function
-  | clear_flag,ElimOnConstr g -> clear_flag,ElimOnConstr (f g)
-  | clear_flag,ElimOnAnonHyp n as x -> x
-  | clear_flag,ElimOnIdent id as x -> x
+let map_destruction_arg f sigma = function
+  | clear_flag,ElimOnConstr g -> let sigma,x = f sigma g in (sigma, (clear_flag,ElimOnConstr x))
+  | clear_flag,ElimOnAnonHyp n as x -> (sigma,x)
+  | clear_flag,ElimOnIdent id as x -> (sigma,x)
+
+let finish_delayed_evar_resolution with_evars env sigma f =
+  let ((c, lbind), sigma') = run_delayed env sigma f in
+  let pending = (sigma,sigma') in
+  let sigma' = Sigma.Unsafe.of_evar_map sigma' in
+  let flags = tactic_infer_flags with_evars in
+  let Sigma (c, sigma', _) = finish_evar_resolution ~flags env sigma' (pending,c) in
+  (Sigma.to_evar_map sigma', (c, lbind))
+
+let with_no_bindings (c, lbind) =
+  if lbind != NoBindings then error "'with' clause not supported here.";
+  c
+
+let force_destruction_arg with_evars env sigma c =
+  map_destruction_arg (finish_delayed_evar_resolution with_evars env) sigma c
 
 (****************************************)
 (* tactic "cut" (actually modus ponens) *)
 (****************************************)
 
+let normalize_cut = false
+
 let cut c =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
     let env = Proofview.Goal.env gl in
-    let sigma = Proofview.Goal.sigma gl in
+    let sigma = Tacmach.New.project 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.unsafe_type_of env sigma c in
-        let typ = whd_betadeltaiota env sigma typ in
+        let typ = whd_all env sigma typ in
         match kind_of_term typ with
         | Sort _ -> true
         | _ -> false
@@ -1038,16 +1231,16 @@ let cut c =
     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
+      let c = if normalize_cut then local_strong whd_betaiota sigma c else c in
+      Refine.refine ~unsafe:true { run = begin fun h ->
+        let Sigma (f, h, p) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in
+        let Sigma (x, h, q) = Evarutil.new_evar env h c in
+        let f = mkLetIn (Name id, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in
+        Sigma (f, h, p +> q)
+      end }
     else
       Tacticals.New.tclZEROMSG (str "Not a proposition or a type.")
-  end
+  end }
 
 let error_uninstantiated_metas t clenv =
   let na = meta_name clenv.evd (List.hd (Metaset.elements (metavars_of t))) in
@@ -1091,11 +1284,11 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true)
   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
-  let exact_tac = Proofview.V82.tactic (refine_no_check new_hyp_prf) in
+  let exact_tac = Proofview.V82.tactic (Tacmach.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)
+    (Proofview.Unsafe.tclEVARS (clear_metas clenv.evd))
     (if sidecond_first then
        Tacticals.New.tclTHENFIRST
          (assert_before_then_gen with_clear naming new_hyp_typ tac) exact_tac
@@ -1130,6 +1323,7 @@ let index_of_ind_arg t =
   in aux None 0 t
 
 let enforce_prop_bound_names rename tac =
+  let open Context.Rel.Declaration in
   match rename with
   | Some (isrec,nn) when Namegen.use_h_based_elimination_names () ->
       (* Rename dependent arguments in Prop with name "H" *)
@@ -1149,19 +1343,19 @@ let enforce_prop_bound_names rename tac =
                 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')
+            mkProd (na,t,aux (push_rel (LocalAssum (na,t)) env) sigma (i-1) t')
         | Prod (Anonymous,t,t') ->
-            mkProd (Anonymous,t,aux (push_rel (Anonymous,None,t) env) sigma (i-1) t')
+            mkProd (Anonymous,t,aux (push_rel (LocalAssum (Anonymous,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
+            mkLetIn (na,c,t,aux (push_rel (LocalDef (na,c,t)) env) sigma (i-1) t')
+        | _ -> print_int i; Feedback.msg_notice (print_constr t); assert false in
       let rename_branch i =
-        Proofview.Goal.nf_enter begin fun gl ->
+        Proofview.Goal.nf_enter { enter = begin fun gl ->
           let env = Proofview.Goal.env gl in
-          let sigma = Proofview.Goal.sigma gl in
+          let sigma = Tacmach.New.project gl in
           let t = Proofview.Goal.concl gl in
           change_concl (aux env sigma i t)
-        end in
+        end } in
       (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn)
         tac
         (Array.map rename_branch nn)
@@ -1176,9 +1370,9 @@ let rec contract_letin_in_lam_header c =
 
 let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags ()) 
     rename i (elim, elimty, bindings) indclause =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
   let env = Proofview.Goal.env gl in
-  let sigma = Proofview.Goal.sigma gl in
+  let sigma = Tacmach.New.project gl in
   let elim = contract_letin_in_lam_header elim in
   let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in
   let indmv =
@@ -1189,7 +1383,7 @@ let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags
   in
   let elimclause' = clenv_fchain ~flags indmv elimclause indclause in
   enforce_prop_bound_names rename (Clenvtac.res_pf elimclause' ~with_evars ~with_classes ~flags)
-  end
+  end }
 
 (*
  * Elimination tactic with bindings and using an arbitrary
@@ -1206,49 +1400,53 @@ type eliminator = {
 }
 
 let general_elim_clause_gen elimtac indclause elim =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
   let env = Proofview.Goal.env gl in
-  let sigma = Proofview.Goal.sigma gl in
+  let sigma = Tacmach.New.project gl in
   let (elimc,lbindelimc) = elim.elimbody 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
   elimtac elim.elimrename i (elimc, elimt, lbindelimc) indclause
-  end
+  end }
 
 let general_elim with_evars clear_flag (c, lbindc) elim =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
   let env = Proofview.Goal.env gl in
-  let sigma = Proofview.Goal.sigma gl in
+  let sigma = Tacmach.New.project 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
+  let sigma = meta_merge sigma (clear_metas indclause.evd) in
+  Proofview.Unsafe.tclEVARS sigma <*>
   Tacticals.New.tclTHEN
     (general_elim_clause_gen elimtac indclause elim)
     (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)
-  end
+  end }
 
 (* 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
+  Proofview.Goal.nf_s_enter { s_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 t = Retyping.get_type_of env sigma c in
-  let (mind,_) = reduce_to_quantified_ind env sigma t in
+  let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in
+  let (mind,_) = reduce_to_quantified_ind env (Sigma.to_evar_map sigma) t in
   let sort = Tacticals.New.elimination_sort_of_goal gl in
-  let sigma, elim =
+  let Sigma (elim, sigma, p) =
     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)
+  let tac =
   (general_elim with_evars clear_flag (c,lbindc)
    {elimindex = None; elimbody = (elim,NoBindings);
     elimrename = Some (false, constructors_nrealdecls (fst mind))})
-  end
+  in
+  Sigma (tac, sigma, p)
+  end }
 
 let general_case_analysis with_evars clear_flag (c,lbindc as cx) =
   match kind_of_term c with
@@ -1259,6 +1457,7 @@ let general_case_analysis with_evars clear_flag (c,lbindc as cx) =
         general_case_analysis_in_context with_evars clear_flag cx
 
 let simplest_case c = general_case_analysis false None (c,NoBindings)
+let simplest_ecase c = general_case_analysis true None (c,NoBindings)
 
 (* Elimination tactic with bindings but using the default elimination
  * constant associated with the type. *)
@@ -1281,15 +1480,17 @@ let find_eliminator c gl =
 
 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)
+    (Proofview.Goal.s_enter { s_enter = begin fun gl ->
+      let sigma, elim = find_eliminator c gl in
+      let tac =
 	  (general_elim with_evars clear_flag cx elim)
-    end)
+      in
+      Sigma.Unsafe.of_pair (tac, sigma)
+    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. *)
+             anymore.  Instead, we do a case analysis. *)
           general_case_analysis with_evars clear_flag cx
       | e -> Proofview.tclZERO ~info e
     end
@@ -1332,9 +1533,9 @@ let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause =
 
 let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) 
     id rename i (elim, elimty, bindings) indclause =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
   let env = Proofview.Goal.env gl in
-  let sigma = Proofview.Goal.sigma gl in
+  let sigma = Tacmach.New.project gl in
   let elim = contract_letin_in_lam_header elim in
   let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in
   let indmv = destMeta (nth_arg i elimclause.templval.rebus) in
@@ -1355,7 +1556,7 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ())
       (str "Nothing to rewrite in " ++ pr_id id ++ str".");
   clenv_refine_in with_evars id id sigma elimclause''
     (fun id -> Proofview.tclUNIT ())
-  end
+  end }
 
 let general_elim_clause with_evars flags id c e =
   let elim = match id with
@@ -1371,11 +1572,13 @@ type conjunction_status =
   | NotADefinedRecordUseScheme of constr
 
 let make_projection env sigma params cstr sign elim i n c u =
+  let open Context.Rel.Declaration in
   let elim = match elim with
   | NotADefinedRecordUseScheme elim ->
       (* bugs: goes from right to left when i increases! *)
-      let (na,b,t) = List.nth cstr.cs_args i in
-      let b = match b with None -> mkRel (i+1) | Some b -> b in
+      let decl = List.nth cstr.cs_args i in
+      let t = get_type decl in
+      let b = match decl with LocalAssum _ -> mkRel (i+1) | LocalDef (_,b,_) -> b in
       let branch = it_mkLambda_or_LetIn b cstr.cs_args in
       if
 	(* excludes dependent projection types *)
@@ -1387,7 +1590,7 @@ let make_projection env sigma params cstr sign elim i n c u =
       then
         let t = lift (i+1-n) t in
 	let abselim = beta_applist (elim,params@[t;branch]) in
-	let c = beta_applist (abselim, [mkApp (c, extended_rel_vect 0 sign)]) in
+	let c = beta_applist (abselim, [mkApp (c, Context.Rel.to_extended_vect 0 sign)]) in
 	  Some (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn t sign)
       else
 	None
@@ -1395,7 +1598,7 @@ let make_projection env sigma params cstr sign elim i n c u =
       (* goes from left to right when i increases! *)
       match List.nth l i with
       | Some proj ->
-	  let args = extended_rel_vect 0 sign in
+	  let args = Context.Rel.to_extended_vect 0 sign in
 	  let proj =
 	    if Environ.is_projection proj env then
 	      mkProj (Projection.make proj false, mkApp (c, args))
@@ -1410,9 +1613,9 @@ let make_projection env sigma params cstr sign elim i n c u =
   in elim
 
 let descend_in_conjunctions avoid tac (err, info) c =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let env = Proofview.Goal.env gl in
-  let sigma = Proofview.Goal.sigma gl in
+  let sigma = Tacmach.New.project gl in
   try
     let t = Retyping.get_type_of env sigma c in
     let ((ind,u),t) = reduce_to_quantified_ind env sigma t in
@@ -1427,13 +1630,15 @@ let descend_in_conjunctions avoid tac (err, info) c =
 	let elim =
 	  try DefinedRecord (Recordops.lookup_projections ind)
 	  with Not_found ->
-	    let elim = build_case_analysis_scheme env sigma (ind,u) false sort in
-	    NotADefinedRecordUseScheme (snd elim) in
-	Tacticals.New.tclFIRST
+            let sigma = Sigma.Unsafe.of_evar_map sigma in
+	    let Sigma (elim, _, _) = build_case_analysis_scheme env sigma (ind,u) false sort in
+	    NotADefinedRecordUseScheme elim in
+	Tacticals.New.tclORELSE0
+	(Tacticals.New.tclFIRST
 	  (List.init n (fun i ->
-            Proofview.Goal.enter begin fun gl ->
+            Proofview.Goal.enter { enter = begin fun gl ->
             let env = Proofview.Goal.env gl in
-            let sigma = Proofview.Goal.sigma gl in
+            let sigma = Tacmach.New.project 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) ->
@@ -1442,31 +1647,32 @@ let descend_in_conjunctions avoid tac (err, info) c =
 		[Proofview.V82.tactic (refine p);
 		 (* Might be ill-typed due to forbidden elimination. *)
 		 Tacticals.New.onLastHypId (tac (not isrec))]
-           end))
+           end })))
+          (Proofview.tclZERO ~info err)
     | None -> Proofview.tclZERO ~info err
   with RefinerError _|UserError _ -> Proofview.tclZERO ~info err
-  end
+  end }
 
 (****************************************************)
 (*            Resolution tactics                    *)
 (****************************************************)
 
 let solve_remaining_apply_goals =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
+  let sigma = Proofview.Goal.sigma gl in
   if !apply_solve_class_goals then
     try 
       let env = Proofview.Goal.env gl in
-      let sigma = Proofview.Goal.sigma gl in
+      let evd = Sigma.to_evar_map sigma 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
+      if Typeclasses.is_class_type evd concl then
+        let evd', c' = Typeclasses.resolve_one_typeclass env evd concl in
+        let tac = Refine.refine ~unsafe:true { run = fun h -> Sigma.here c' h } in
+        Sigma.Unsafe.of_pair (tac, evd')
+	else Sigma.here (Proofview.tclUNIT ()) sigma
+    with Not_found -> Sigma.here (Proofview.tclUNIT ()) sigma
+  else Sigma.here (Proofview.tclUNIT ()) sigma
+  end }
 
 let tclORELSEOPT t k =
   Proofview.tclORELSE t
@@ -1477,27 +1683,27 @@ let tclORELSEOPT t k =
     | Some tac -> tac)
 
 let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { 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
   (* 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 concl in
+  let concl_nprod = nb_prod_modulo_zeta concl in
   let rec try_main_apply with_destruct c =
-    Proofview.Goal.enter begin fun gl ->
+    Proofview.Goal.enter { enter = begin fun gl ->
     let env = Proofview.Goal.env gl in
-    let sigma = Proofview.Goal.sigma gl in
+    let sigma = Tacmach.New.project gl in
 
     let thm_ty0 = nf_betaiota sigma (Retyping.get_type_of env sigma c) in
     let try_apply thm_ty nprod =
       try
-        let n = nb_prod thm_ty - nprod in
+        let n = nb_prod_modulo_zeta 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 ->
+      with exn when catchable_exception exn ->
         Proofview.tclZERO exn
     in
     let rec try_red_apply thm_ty (exn0, info) =
@@ -1520,7 +1726,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind))
               (fun b id ->
                 Tacticals.New.tclTHEN
                   (try_main_apply b (mkVar id))
-                  (Proofview.V82.tactic (thin [id])))
+                  (clear [id]))
               (exn0, info) c
           else
             Proofview.tclZERO ~info exn0 in
@@ -1540,14 +1746,14 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind))
       | PretypeError _|RefinerError _|UserError _|Failure _ ->
         Some (try_red_apply thm_ty0 (e, info))
       | _ -> None)
-    end
+    end }
   in
     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
+  end }
 
 let rec apply_with_bindings_gen b e = function
   | [] -> Proofview.tclUNIT ()
@@ -1559,13 +1765,13 @@ let rec apply_with_bindings_gen b e = function
 
 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
+    Proofview.Goal.enter { enter = begin fun gl ->
+      let sigma = Tacmach.New.project gl in
       let env = Proofview.Goal.env gl in
-      let sigma, cb = f env sigma in
+      let (cb, sigma) = run_delayed env sigma f in
 	Tacticals.New.tclWITHHOLES e
           (general_apply b b e k (loc,cb)) sigma
-    end
+    end }
   in
   let rec aux = function
     | [] -> Proofview.tclUNIT ()
@@ -1619,8 +1825,8 @@ 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 e when Errors.noncritical e ->
-    let e = Errors.push e in
+    with e when CErrors.noncritical e ->
+    let e = CErrors.push e in
     try aux (clenv_push_prod clause)
     with NotExtensibleClause -> iraise e
   in
@@ -1628,48 +1834,49 @@ let apply_in_once_main flags innerclause env sigma (d,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 open Context.Rel.Declaration in
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let env = Proofview.Goal.env gl in
-  let sigma = Proofview.Goal.sigma gl in
+  let sigma = Tacmach.New.project 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 targetid = find_name true (LocalAssum (Anonymous,t')) naming gl in
   let rec aux idstoclear with_destruct c =
-    Proofview.Goal.enter begin fun gl ->
+    Proofview.Goal.enter { enter = begin fun gl ->
     let env = Proofview.Goal.env gl in
-    let sigma = Proofview.Goal.sigma gl in
+    let sigma = Tacmach.New.project gl in
     try
       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);
+            clear idstoclear;
             tac id
           ])
-    with e when with_destruct && Errors.noncritical e ->
-      let (e, info) = Errors.push e in
+    with e when with_destruct && CErrors.noncritical e ->
+      let (e, info) = CErrors.push e in
         (descend_in_conjunctions [targetid]
            (fun b id -> aux (id::idstoclear) b (mkVar id))
            (e, info) c)
-    end
+    end }
   in
   aux [] with_destruct d
-  end
+  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 ->
+  Proofview.Goal.enter { 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
+    let sigma = Tacmach.New.project gl in
+    let (c, sigma) = run_delayed env sigma f in
     Tacticals.New.tclWITHHOLES with_evars 
       (apply_in_once sidecond_first with_delta with_destruct with_evars
          naming id (clear_flag,(loc,c)) tac)
       sigma
-  end
+  end }
 
 (* A useful resolution tactic which, if c:A->B, transforms |- C into
    |- B -> C and |- A
@@ -1689,20 +1896,20 @@ let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars nam
 *)
 
 let cut_and_apply c =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
     match kind_of_term (Tacmach.New.pf_hnf_constr gl (Tacmach.New.pf_unsafe_type_of gl c)) with
       | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) ->
         let concl = Proofview.Goal.concl gl in
         let env = Tacmach.New.pf_env gl in
-        Proofview.Refine.refine begin fun sigma ->
+        Refine.refine { run = 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 Sigma (f, sigma, p) = Evarutil.new_evar env sigma typ in
+          let Sigma (x, sigma, q) = Evarutil.new_evar env sigma c1 in
           let ans = mkApp (f, [|mkApp (c, [|x|])|]) in
-          (sigma, ans)
-        end
+          Sigma (ans, sigma, p +> q)
+        end }
       | _ -> error "lapply needs a non-dependent product."
-  end
+  end }
 
 (********************************************************************)
 (*               Exact tactics                                      *)
@@ -1714,45 +1921,55 @@ let cut_and_apply c =
 (* 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_no_check c =
+  Refine.refine ~unsafe:true { run = fun h -> Sigma.here c h }
 
 let exact_check c =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.s_enter { s_enter = begin fun gl ->
+  let sigma = Proofview.Goal.sigma gl in
   (** 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 = Sigma.to_evar_map sigma in
   let sigma, ct = Typing.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
-
-let vm_cast_no_check c gl =
-  let concl = pf_concl gl in
-  refine_no_check (Term.mkCast(c,Term.VMcast,concl)) gl
+  let tac =
+      Tacticals.New.tclTHEN (convert_leq ct concl) (exact_no_check c)
+  in
+  Sigma.Unsafe.of_pair (tac, sigma)
+  end }
 
-let native_cast_no_check c gl =
-  let concl = pf_concl gl in
-  refine_no_check (Term.mkCast(c,Term.NATIVEcast,concl)) gl
+let cast_no_check cast c =
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in
+    exact_no_check (Term.mkCast (c, cast, concl))
+  end }
 
+let vm_cast_no_check c = cast_no_check Term.VMcast c
+let native_cast_no_check c = cast_no_check Term.NATIVEcast c
 
-let exact_proof c gl =
-  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 exact_proof c =
+  let open Tacmach.New in
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
+  Refine.refine { run = begin fun sigma ->
+    let sigma = Sigma.to_evar_map sigma in
+    let (c, ctx) = Constrintern.interp_casted_constr (pf_env gl) sigma c (pf_concl gl) in
+    let sigma = Evd.merge_universe_context sigma ctx in
+    Sigma.Unsafe.of_pair (c, sigma)
+  end }
+  end }
 
 let assumption =
+  let open Context.Named.Declaration in
   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 ->
+  | decl::rest ->
+    let t = get_type decl in
     let concl = Proofview.Goal.concl gl in
-    let sigma = Proofview.Goal.sigma gl in
+    let sigma = Tacmach.New.project gl in
     let (sigma, is_same_type) =
       if only_eq then (sigma, Constr.equal t concl)
       else
@@ -1761,101 +1978,103 @@ let assumption =
     in
     if is_same_type then
       (Proofview.Unsafe.tclEVARS sigma) <*>
-	Proofview.Refine.refine ~unsafe:true (fun h -> (h, mkVar id))
+	exact_no_check (mkVar (get_id decl))
     else arec gl only_eq rest
   in
-  let assumption_tac gl =
+  let assumption_tac = { enter = begin fun gl ->
     let hyps = Proofview.Goal.hyps gl in
     arec gl true hyps
-  in
+  end } in
   Proofview.Goal.nf_enter assumption_tac
 
 (*****************************************************************)
 (*          Modification of a local context                      *)
 (*****************************************************************)
 
-(* This tactic enables the user to remove hypotheses from the signature.
- * Some care is taken to prevent him from removing variables that are
- * subsequently used in other hypotheses or in the conclusion of the
- * goal. *)
-
-let clear ids = (* avant seul dyn_clear n'echouait pas en [] *)
-  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 ->
+exception DependsOnBody of Id.t option
+
+let check_is_type env sigma ty =
   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 check_decl env (_, c, ty) msg =
-  Proofview.tclEVARMAP >>= fun sigma ->
+    let _ = Typing.e_sort_of env evdref ty in
+    !evdref
+  with e when CErrors.noncritical e ->
+    raise (DependsOnBody None)
+
+let check_decl env sigma decl =
+  let open Context.Named.Declaration in
+  let ty = get_type decl in
   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
+    let _ = Typing.e_sort_of env evdref ty in
+    let _ = match decl with
+    | LocalAssum _ -> ()
+    | LocalDef (_,c,_) -> Typing.e_check env evdref c ty
     in
-    Proofview.Unsafe.tclEVARS !evdref
-  with e when Errors.noncritical e ->
-    msg e
+    !evdref
+  with e when CErrors.noncritical e ->
+    let id = get_id decl in
+    raise (DependsOnBody (Some id))
 
 let clear_body ids =
-  Proofview.Goal.enter begin fun gl ->
+  let open Context.Named.Declaration in
+  Proofview.Goal.enter { enter = begin fun gl ->
     let env = Proofview.Goal.env gl in
     let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in
+    let sigma = Tacmach.New.project gl in
     let ctx = named_context env in
-    let map (id, body, t as decl) = match body with
-    | None ->
+    let map = function
+    | LocalAssum (id,t) as decl ->
       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
+    | LocalDef (id,_,t) as decl ->
+      if List.mem_f Id.equal id ids then LocalAssum (id, 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)
+    let check =
+      try
+        let check (env, sigma, seen) decl =
+          (** Do no recheck hypotheses that do not depend *)
+          let sigma =
+            if not seen then sigma
+            else if List.exists (fun id -> occur_var_in_decl env id decl) ids then
+              check_decl env sigma decl
+            else sigma
+          in
+          let seen = seen || List.mem_f Id.equal (get_id decl) ids in
+          (push_named decl env, sigma, seen)
         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
+        let (env, sigma, _) = List.fold_left check (base_env, sigma, false) (List.rev ctx) in
+        let sigma =
+          if List.exists (fun id -> occur_var env id concl) ids then
+            check_is_type env sigma concl
+          else sigma
+        in
+        Proofview.Unsafe.tclEVARS sigma
+      with DependsOnBody where ->
+        let msg = match where with
+        | None -> str "Conclusion" ++ on_the_bodies ids
+        | Some id -> str "Hypothesis " ++ pr_id id ++ on_the_bodies ids
+        in
+        Tacticals.New.tclZEROMSG msg
     in
-    check_hyps <*> check_concl <*>
-    Proofview.Refine.refine ~unsafe:true begin fun sigma ->
+    check <*>
+    Refine.refine ~unsafe:true { run = begin fun sigma ->
       Evarutil.new_evar env sigma ~principal:true concl
-    end
-  end
+    end }
+  end }
 
 let clear_wildcards ids =
-  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) (project gl) (Id.of_string "_") err))
-    ids)
+  Tacticals.New.tclMAP (fun (loc, id) -> clear [id]) ids
 
 (*   Takes a list of booleans, and introduces all the variables
  *  quantified in the goal which are associated with a value
@@ -1866,51 +2085,18 @@ let rec intros_clearing = function
   | (false::tl) -> Tacticals.New.tclTHEN intro (intros_clearing tl)
   | (true::tl)  ->
       Tacticals.New.tclTHENLIST
-        [ intro; Tacticals.New.onLastHypId (fun id -> Proofview.V82.tactic (clear [id])); intros_clearing tl]
-
-(* Modifying/Adding an hypothesis  *)
-
-let specialize (c,lbind) g =
-  let tac, term =
-    if lbind == NoBindings then
-      let evd = Typeclasses.resolve_typeclasses (pf_env g) (project g) in
-	tclEVARS evd, nf_evar evd c
-    else
-      let clause = pf_apply make_clenv_binding g (c,pf_unsafe_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_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 " ++
-          pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++
-	  str ".");
-       tclEVARS clause.evd, term
-  in
-  match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with
-       | Var id when Id.List.mem id (pf_ids_of_hyps g) ->
-	   tclTHEN tac
-	     (tclTHENFIRST
-	       (fun g -> Proofview.V82.of_tactic (assert_before_replacing id (pf_unsafe_type_of g term)) g)
-	       (exact_no_check term)) g
-       | _ -> tclTHEN tac
-	   (tclTHENLAST
-              (fun g -> Proofview.V82.of_tactic (cut (pf_unsafe_type_of g term)) g)
-              (exact_no_check term)) g
+        [ intro; Tacticals.New.onLastHypId (fun id -> clear [id]); intros_clearing tl]
 
 (* Keeping only a few hypotheses *)
 
 let keep hyps =
-  Proofview.Goal.nf_enter begin fun gl ->
+  let open Context.Named.Declaration in
+  Proofview.Goal.nf_enter { 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) ->
+    fold_named_context_reverse (fun (clear,keep) decl ->
+      let hyp = get_id decl in
       if Id.List.mem hyp hyps
         || List.exists (occur_var_in_decl env hyp) keep
 	|| occur_var env hyp ccl
@@ -1918,8 +2104,55 @@ let keep hyps =
       else (hyp::clear,keep))
       ~init:([],[]) (Proofview.Goal.env gl)
   in
-  Proofview.V82.tactic (fun gl -> thin cl gl)
-  end
+  clear cl
+  end }
+
+(*********************************)
+(*  Basic 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 newcl args =
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let store = Proofview.Goal.extra gl in
+    Refine.refine { run = begin fun sigma ->
+      let newcl = nf_betaiota (Sigma.to_evar_map sigma) newcl (* As in former Logic.refine *) in
+      let Sigma (ev, sigma, p) =
+        Evarutil.new_evar env sigma ~principal:true ~store newcl in
+      Sigma (applist (ev, args), sigma, p)
+    end }
+  end }
+
+(* 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 { enter = begin fun gl ->
+      let env = Proofview.Goal.env gl in
+      let store = Proofview.Goal.extra 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 (Context.Named.to_instance hyps) in
+      Refine.refine { run = begin fun sigma ->
+        let Sigma (ev, sigma, p) =
+          Evarutil.new_evar env sigma ~principal:true ~store newcl in
+        Sigma (mkApp (ev, args), sigma, p)
+      end }
+    end }
+
+let revert hyps = 
+  Proofview.Goal.enter { 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) <*> (clear hyps)
+  end }
 
 (************************)
 (* Introduction tactics *)
@@ -1936,7 +2169,8 @@ let check_number_of_constructors expctdnumopt i nconstr =
   if i > nconstr then error "Not enough constructors."
 
 let constructor_tac with_evars expctdnumopt i lbind =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.s_enter { s_enter = begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
     let cl = Tacmach.New.pf_nf_concl gl in
     let reduce_to_quantified_ind =
       Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl
@@ -1946,16 +2180,19 @@ let constructor_tac with_evars expctdnumopt i lbind =
       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 Sigma (cons, sigma, p) = Sigma.fresh_constructor_instance
+	(Proofview.Goal.env gl) sigma (fst mind, i) in
       let cons = mkConstructU cons in
 	
       let apply_tac = general_apply true false with_evars None (dloc,(cons,lbind)) in
+      let tac =
 	(Tacticals.New.tclTHENLIST
-           [Proofview.Unsafe.tclEVARS sigma; 
+           [
 	    convert_concl_no_check redcl DEFAULTcast;
 	    intros; apply_tac])
-  end
+      in
+      Sigma (tac, sigma, p)
+  end }
 
 let one_constructor i lbind = constructor_tac false None i lbind
 
@@ -1972,7 +2209,7 @@ let rec tclANY tac = function
 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 ->
+  Proofview.Goal.enter { 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
@@ -1982,7 +2219,7 @@ let any_constructor with_evars tacopt =
       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
+ 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
@@ -2033,7 +2270,7 @@ let my_find_eq_data_decompose gl t =
   | Constr_matching.PatternMatchingFailure -> None
 
 let intro_decomp_eq loc l thin tac id =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
   let c = mkVar id in
   let t = Tacmach.New.pf_unsafe_type_of gl c in
   let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in
@@ -2044,53 +2281,65 @@ let intro_decomp_eq loc l thin tac id =
     (eq,t,eq_args) (c, t)
   | None ->
     Tacticals.New.tclZEROMSG (str "Not a primitive equality here.")
-  end
+  end }
 
-let intro_or_and_pattern loc bracketed ll thin tac id =
-  Proofview.Goal.enter begin fun gl ->
+let intro_or_and_pattern loc with_evars bracketed ll thin tac id =
+  Proofview.Goal.enter { enter = begin fun gl ->
   let c = mkVar id in
   let t = Tacmach.New.pf_unsafe_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);
+  let (ind,t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in
+  let branchsigns = compute_constructor_signatures false ind in
+  let nv_with_let = Array.map List.length branchsigns in
+  let ll = fix_empty_or_and_pattern (Array.length branchsigns) ll in
+  let ll = get_and_check_or_and_pattern loc ll branchsigns in
   Tacticals.New.tclTHENLASTn
-    (Tacticals.New.tclTHEN (simplest_case c) (Proofview.V82.tactic (clear [id])))
+    (Tacticals.New.tclTHEN (simplest_ecase c) (clear [id]))
     (Array.map2 (fun n l -> tac thin (Some (bracketed,n)) l)
-       nv (Array.of_list ll))
-  end
+       nv_with_let ll)
+  end }
 
-let rewrite_hyp assert_style l2r id =
+let rewrite_hyp_then assert_style with_evars thin l2r id tac =
   let rew_on l2r =
-    Hook.get forward_general_rewrite_clause l2r false (mkVar id,NoBindings) in
+    Hook.get forward_general_rewrite_clause l2r with_evars (mkVar id,NoBindings) in
   let subst_on l2r x rhs =
     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 clear_var_and_eq id' = clear [id';id] in
+  let early_clear id' thin =
+    List.filter (fun (_,id) -> not (Id.equal id id')) thin in
+  Proofview.Goal.enter { enter = begin fun gl ->
     let env = Proofview.Goal.env gl in
     let type_of = Tacmach.New.pf_unsafe_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
+    let whd_all = Tacmach.New.pf_apply whd_all gl in
+    let t = whd_all (type_of (mkVar id)) in
+    let eqtac, thin = 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
+          let id' = destVar lhs in
+          subst_on l2r id' rhs, early_clear id' thin
         else if not l2r && isVar rhs && not (occur_var env (destVar rhs) lhs) then
-          subst_on l2r (destVar rhs) lhs
+          let id' = destVar rhs in
+          subst_on l2r id' lhs, early_clear id' thin
         else
-          Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id]))
+          Tacticals.New.tclTHEN (rew_on l2r onConcl) (clear [id]),
+          thin
     | Some (hdcncl,[c]) ->
         let l2r = not l2r in (* equality of the form eq_true *)
         if isVar c then
+          let id' = destVar c in
           Tacticals.New.tclTHEN (rew_on l2r allHypsAndConcl) 
-	    (Proofview.V82.tactic (clear_var_and_eq c))
+	    (clear_var_and_eq id'),
+          early_clear id' thin
         else
-          Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id]))
+          Tacticals.New.tclTHEN (rew_on l2r onConcl) (clear [id]),
+          thin
     | _ ->
-        Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id]))
-  end
+        Tacticals.New.tclTHEN (rew_on l2r onConcl) (clear [id]),
+        thin in
+    (* Skip the side conditions of the rewriting step *)
+    Tacticals.New.tclTHENFIRST eqtac (tac thin)
+  end }
 
-let rec prepare_naming loc = function
+let prepare_naming loc = function
   | IntroIdentifier id -> NamingMustBe (loc,id)
   | IntroAnonymous -> NamingAvoid []
   | IntroFresh id -> NamingBasedOn (id,[])
@@ -2098,7 +2347,8 @@ let rec prepare_naming loc = function
 let rec explicit_intro_names = function
 | (_, IntroForthcoming _) :: l -> explicit_intro_names l
 | (_, IntroNaming (IntroIdentifier id)) :: l -> id :: explicit_intro_names l
-| (_, IntroAction (IntroOrAndPattern ll)) :: l' ->
+| (_, IntroAction (IntroOrAndPattern l)) :: l' ->
+    let ll = match l with IntroAndPattern l -> [l] | IntroOrPattern ll -> ll in
     List.flatten (List.map (fun l -> explicit_intro_names (l@l')) ll)
 | (_, IntroAction (IntroInjection l)) :: l' ->
     explicit_intro_names (l@l')
@@ -2161,12 +2411,13 @@ let exceed_bound n = function
      [patl]: introduction patterns to interpret
   *)
 
-let rec intro_patterns_core b avoid ids thin destopt bound n tac = function
+let rec intro_patterns_core with_evars 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
+      intro_patterns_core with_evars 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
@@ -2174,98 +2425,100 @@ let rec intro_patterns_core b avoid ids thin destopt bound n tac = function
   | 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
+        (fun ids -> intro_patterns_core with_evars b avoid ids thin destopt bound
           (n+List.length ids) tac l)
   | IntroAction pat ->
       intro_then_gen (make_tmp_naming avoid l pat)
 	destopt true false
-        (intro_pattern_action loc (b || not (List.is_empty l)) false pat thin
-          destopt
-          (fun thin bound' -> intro_patterns_core b avoid ids thin destopt bound' 0
+        (intro_pattern_action loc with_evars (b || not (List.is_empty l)) false
+          pat thin destopt
+          (fun thin bound' -> intro_patterns_core with_evars b avoid ids thin destopt bound' 0
             (fun ids thin ->
-              intro_patterns_core b avoid ids thin destopt bound (n+1) tac l)))
+              intro_patterns_core with_evars b avoid ids thin destopt bound (n+1) tac l)))
   | IntroNaming pat ->
-      intro_pattern_naming loc b avoid ids pat thin destopt bound (n+1) tac l
+      intro_pattern_naming loc with_evars b avoid ids pat thin destopt bound (n+1) tac l
 
   (* Pi-introduction rule, used backwards *)
-and intro_pattern_naming loc b avoid ids pat thin destopt bound n tac l =
+and intro_pattern_naming loc with_evars 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 (NamingMustBe (loc,id)) destopt true false
-          (fun id -> intro_patterns_core b avoid (id::ids) thin destopt bound n tac l))
+          (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l))
   | IntroAnonymous ->
       intro_then_gen (NamingAvoid (avoid@explicit_intro_names l))
 	destopt true false
-        (fun id -> intro_patterns_core b avoid (id::ids) thin destopt bound n tac l)
+        (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l)
   | IntroFresh id ->
       (* todo: avoid thinned names to interfere with generation of fresh name *)
       intro_then_gen (NamingBasedOn (id, avoid@explicit_intro_names l))
 	destopt true false
-        (fun id -> intro_patterns_core b avoid (id::ids) thin destopt bound n tac l)
+        (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l)
 
-and intro_pattern_action loc b style pat thin destopt tac id = match pat with
+and intro_pattern_action loc with_evars b style pat thin destopt tac id =
+  match pat with
   | IntroWildcard ->
       tac ((loc,id)::thin) None []
   | IntroOrAndPattern ll ->
-      intro_or_and_pattern loc b ll thin tac id
+      intro_or_and_pattern loc with_evars 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 [])
+      rewrite_hyp_then style with_evars thin l2r id (fun thin -> tac thin None [])
   | IntroApplyOn (f,(loc,pat)) ->
       let naming,tac_ipat =
-        prepare_intros_loc loc (IntroIdentifier id) destopt pat in
+        prepare_intros_loc loc with_evars (IntroIdentifier id) destopt pat in
       let doclear =
         if naming = NamingMustBe (loc,id) then
           Proofview.tclUNIT () (* apply_in_once do a replacement *)
         else
-          Proofview.V82.tactic (clear [id]) in
-      let f env sigma = let (sigma,c) = f env sigma in (sigma,(c,NoBindings)) in
-      apply_in_delayed_once false true true true naming id (None,(loc,f))
+          clear [id] in
+      let f = { delayed = fun env sigma ->
+        let Sigma (c, sigma, p) = f.delayed env sigma in
+        Sigma ((c, NoBindings), sigma, p)
+      } in
+      apply_in_delayed_once false true true with_evars naming id (None,(loc,f))
         (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []])
 
-and prepare_intros_loc loc dft destopt = function
+and prepare_intros_loc loc with_evars dft destopt = function
   | IntroNaming ipat ->
       prepare_naming loc ipat,
-      (fun id -> Proofview.V82.tactic (move_hyp id destopt))
+      (fun id -> move_hyp id destopt)
   | IntroAction ipat ->
       prepare_naming loc dft,
       (let tac thin bound =
-        intro_patterns_core true [] [] thin destopt bound 0
+        intro_patterns_core with_evars true [] [] thin destopt bound 0
           (fun _ l -> clear_wildcards l) in
-      fun id -> intro_pattern_action loc true true ipat [] destopt tac id)
+      fun id ->
+        intro_pattern_action loc with_evars true true ipat [] destopt 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
+let intro_patterns_bound_to with_evars n destopt =
+  intro_patterns_core with_evars true [] [] [] destopt
     (Some (true,n)) 0 (fun _ l -> clear_wildcards l)
 
-let intro_patterns_to destopt =
-  intro_patterns_core (use_bracketing_last_or_and_intro_pattern ())
+let intro_patterns_to with_evars destopt =
+  intro_patterns_core with_evars (use_bracketing_last_or_and_intro_pattern ())
     [] [] [] destopt None 0 (fun _ l -> clear_wildcards l)
 
-let intro_pattern_to destopt pat =
-  intro_patterns_to destopt [dloc,pat]
+let intro_pattern_to with_evars destopt pat =
+  intro_patterns_to with_evars destopt [dloc,pat]
 
-let intro_patterns = intro_patterns_to MoveLast
+let intro_patterns with_evars = intro_patterns_to with_evars MoveLast
 
 (* Implements "intros" *)
-let intros_patterns = function
+let intros_patterns with_evars = function
   | [] -> intros
-  | l -> intro_patterns_to MoveLast l
+  | l -> intro_patterns_to with_evars MoveLast l
 
 (**************************)
 (*   Forward reasoning    *)
 (**************************)
 
-let prepare_intros dft destopt = function
+let prepare_intros with_evars dft destopt = function
   | None -> prepare_naming dloc dft, (fun _id -> Proofview.tclUNIT ())
-  | Some (loc,ipat) -> prepare_intros_loc loc dft destopt ipat
+  | Some (loc,ipat) -> prepare_intros_loc loc with_evars dft destopt ipat
 
 let ipat_of_name = function
   | Anonymous -> None
@@ -2276,7 +2529,7 @@ let head_ident c =
    if isVar c then Some (destVar c) else None
 
 let assert_as first hd ipat t =
-  let naming,tac = prepare_intros IntroAnonymous MoveLast ipat in
+  let naming,tac = prepare_intros false IntroAnonymous MoveLast ipat in
   let repl = do_replace hd naming in
   let tac = if repl then (fun id -> Proofview.tclUNIT ()) else tac in
   if first then assert_before_then_gen repl naming t tac
@@ -2289,18 +2542,19 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars
   let tac (naming,lemma) tac id =
     apply_in_delayed_once sidecond_first with_delta with_destruct with_evars
       naming id lemma tac in
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
   let destopt =
     if with_evars then MoveLast (* evars would depend on the whole context *)
     else get_previous_hyp_position id gl in
-  let naming,ipat_tac = prepare_intros (IntroIdentifier id) destopt ipat in
+  let naming,ipat_tac =
+    prepare_intros with_evars (IntroIdentifier id) destopt 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
-  end
+  end }
 
 (*
   if sidecond_first then
@@ -2311,7 +2565,7 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars
 *)
 
 let apply_in simple with_evars id lemmas ipat =
-  let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, fun _ sigma -> sigma, l)) lemmas in
+  let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, { delayed = fun _ sigma -> Sigma.here l sigma })) lemmas in
   general_apply_in false simple simple with_evars id lemmas ipat
 
 let apply_delayed_in simple with_evars id lemmas ipat =
@@ -2324,13 +2578,6 @@ let apply_delayed_in simple with_evars id lemmas ipat =
 (* 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
@@ -2342,16 +2589,17 @@ let decode_hyp = function
 *)
 
 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
+  Proofview.Goal.s_enter { s_enter = begin fun gl ->
     let sigma = Proofview.Goal.sigma gl in
-    let (sigma, t) = match ty with
-    | Some t -> (sigma, t)
+    let env = Proofview.Goal.env gl in
+    let Sigma (t, sigma, p) = match ty with
+    | Some t -> Sigma.here t sigma
     | None ->
       let t = typ_of env sigma c in
-      Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma t
+      let sigma, c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env (Sigma.to_evar_map sigma) t in
+      Sigma.Unsafe.of_pair (c, sigma)
     in
-    let eq_tac gl = match with_eq with
+    let Sigma ((newcl, eq_tac), sigma, q) = match with_eq with
       | Some (lr,(loc,ido)) ->
           let heq = match ido with
             | IntroAnonymous -> new_fresh_id [id] (add_prefix "Heq" id) gl
@@ -2359,42 +2607,51 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty =
             | 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 Sigma (eq, sigma, p) = Sigma.fresh_global env sigma eqdata.eq in
+          let Sigma (refl, sigma, q) = Sigma.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 = Sigma.to_evar_map sigma in
 	  let sigma, _ = Typing.type_of env sigma term in
-            sigma, term,
+          let ans = term,
             Tacticals.New.tclTHEN
 	      (intro_gen (NamingMustBe (loc,heq)) (decode_hyp lastlhyp) true false)
 	      (clear_body [heq;id])
+          in
+          Sigma.Unsafe.of_pair (ans, sigma)
       | 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;
+          Sigma.here (mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) sigma
+    in
+    let tac =
+      Tacticals.New.tclTHENLIST
+      [ 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
+    in
+    Sigma (tac, sigma, p +> q)
+  end }
 
 let insert_before decls lasthyp env =
+  let open Context.Named.Declaration in
   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
+    (fun _ d env ->
+      let env = if Id.equal id (get_id d) 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 open Context.Named.Declaration in
   let t = match ty with Some t -> t | _ -> typ_of env sigma c in
+  let decl = if dep then LocalDef (id,c,t)
+	     else LocalAssum (id,t)
+  in
   match with_eq with
   | Some (lr,(loc,ido)) ->
       let heq = match ido with
@@ -2406,56 +2663,65 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty =
           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 Sigma (eq, sigma, p) = Sigma.fresh_global env sigma eqdata.eq in
+      let Sigma (refl, sigma, q) = Sigma.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))
+      let newenv = insert_before [LocalAssum (heq,eq); decl] lastlhyp env in
+      let Sigma (x, sigma, r) = new_evar newenv sigma ~principal:true ~store ccl in
+      Sigma (mkNamedLetIn id c t (mkNamedLetIn heq refl eq x), sigma, p +> q +> r)
   | 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 newenv = insert_before [decl] lastlhyp env in
+      let Sigma (x, sigma, p) = new_evar newenv sigma ~principal:true ~store ccl in
+      Sigma (mkNamedLetIn id c t x, sigma, p)
 
 let letin_tac with_eq id c ty occs =
-  Proofview.Goal.nf_enter begin fun gl ->
-    let env = Proofview.Goal.env gl in
+  Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
     let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env 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 (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in
+    (* We keep the original term to match but record the potential side-effects
+       of unifying universes. *)
+    let Sigma (c, sigma, p) = match res with
+      | None -> Sigma.here c sigma
+      | Some (Sigma (_, sigma, p)) -> Sigma (c, sigma, p)
+    in
+    let tac = letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty in
+    Sigma (tac, sigma, p)
+  end }
 
 let letin_pat_tac with_eq id c occs =
-  Proofview.Goal.nf_enter begin fun gl ->
-    let env = Proofview.Goal.env gl in
+  Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
     let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env 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
+    let Sigma (c, sigma, p) = 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)
+    | Some res -> res in
+    let tac =
       (letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) None)
-  end
+    in
+    Sigma (tac, sigma, p)
+  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_unsafe_type_of gl c in
+      Proofview.Goal.enter { enter = begin fun gl ->
+      let t = Tacmach.New.pf_get_type_of gl c in
       let hd = head_ident c in
-      Tacticals.New.tclTHENFIRST (assert_as true hd ipat t)
-	(Proofview.V82.tactic (exact_no_check c))
-      end
+      Tacticals.New.tclTHENFIRST (assert_as true hd ipat t) (exact_no_check c)
+      end }
   | Some tac ->
+      let tac = match tac with
+        | None -> Tacticals.New.tclIDTAC
+        | Some tac -> Tacticals.New.tclCOMPLETE tac in
       if b then
         Tacticals.New.tclTHENFIRST (assert_as b None ipat c) tac
       else
@@ -2463,47 +2729,13 @@ let forward b usetac ipat c =
           (assert_as b None 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
+let assert_by na t tac = forward true (Some (Some tac)) (ipat_of_name na) t
+let enough_by na t tac = forward false (Some (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 store = Proofview.Goal.extra 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 ~principal:true ~store 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
@@ -2527,100 +2759,117 @@ let generalized_name c t ids cl = function
    [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 generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl =
+  let open Context.Rel.Declaration in
   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_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 cl',sigma' = subst_closed_term_occ env sigma (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 decl = match b with
+    | None -> LocalAssum (na,t)
+    | Some b -> LocalDef (na,b,t)
+  in
+  mkProd_or_LetIn decl cl', sigma'
 
-let generalize_goal gl i ((occs,c,b),na as o) cl =
-  let t = pf_unsafe_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_goal gl i ((occs,c,b),na as o) (cl,sigma) =
+  let env = Tacmach.pf_env gl in
+  let ids = Tacmach.pf_ids_of_hyps gl in
+  let sigma, t = Typing.type_of env sigma c in
+  generalize_goal_gen env sigma ids i o t cl
 
-let generalize_dep ?(with_let=false) c gl =
+let old_generalize_dep ?(with_let=false) c gl =
+  let open Context.Named.Declaration in
   let env = pf_env gl in
   let sign = pf_hyps gl in
   let init_ids = ids_of_named_context (Global.named_context()) in
-  let seek d toquant =
-    if List.exists (fun (id,_,_) -> occur_var_in_decl env id d) toquant
+  let seek (d:Context.Named.Declaration.t) (toquant:Context.Named.t) =
+    if List.exists (fun d' -> occur_var_in_decl env (get_id d') d) toquant
       || dependent_in_decl c d then
       d::toquant
     else
       toquant in
-  let to_quantify = Context.fold_named_context seek sign ~init:[] in
+  let to_quantify = Context.Named.fold_outside 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 qhyps = List.map get_id to_quantify_rev 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 (Id.List.mem id init_ids)
+      | Var id when mem_named_context_val id (val_of_named_context 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 cl' = it_mkNamedProd_or_LetIn (Tacmach.pf_concl gl) to_quantify in
   let body =
     if with_let then
       match kind_of_term c with
-      | Var id -> pi2 (pf_get_hyp gl id)
+      | Var id -> Tacmach.pf_get_hyp gl id |> get_value
       | _ -> None
     else None
   in
   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
+  (** Check that the generalization is indeed well-typed *)
+  let (evd, _) = Typing.type_of env evd cl'' in
+  let args = Context.Named.to_instance to_quantify_rev in
   tclTHENLIST
     [tclEVARS evd;
-     apply_type cl'' (if Option.is_empty body then c::args else args);
-     thin (List.rev tothin')]
+     Proofview.V82.of_tactic (apply_type cl'' (if Option.is_empty body then c::args else args));
+     Proofview.V82.of_tactic (clear (List.rev tothin'))]
     gl
 
+let generalize_dep ?(with_let = false) c =
+  Proofview.V82.tactic (old_generalize_dep ~with_let c)
+
 (**  *)
-let generalize_gen_let lconstr gl =
+let generalize_gen_let lconstr = Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
+  let env = Proofview.Goal.env gl in
   let newcl, evd =
-    List.fold_right_i (generalize_goal gl) 0 lconstr
-      (pf_concl gl,project gl)
+    List.fold_right_i (Tacmach.New.of_old generalize_goal gl) 0 lconstr
+      (Tacmach.New.pf_concl gl,Tacmach.New.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 (evd, _) = Typing.type_of env evd newcl in
+  let map ((_, c, b),_) = if Option.is_empty b then Some c else None in
+  let tac = apply_type newcl (List.map_filter map lconstr) in
+  Sigma.Unsafe.of_pair (tac, evd)
+end }
 
 let new_generalize_gen_let lconstr =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.s_enter { s_enter = begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
     let gl = Proofview.Goal.assume gl in
     let concl = Proofview.Goal.concl gl in
-    let sigma = Proofview.Goal.sigma gl in
+    let sigma = Sigma.to_evar_map sigma in
     let env = Proofview.Goal.env gl in
     let ids = Tacmach.New.pf_ids_of_hyps gl in
-    let (newcl, sigma), args =
+    let newcl, sigma, args =
       List.fold_right_i 
-	(fun i ((_,c,b),_ as o) (cl, args) ->
-	  let t = Tacmach.New.pf_unsafe_type_of gl c in
+	(fun i ((_,c,b),_ as o) (cl, sigma, args) ->
+	  let sigma, t = Typing.type_of env sigma 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), [])
+          let cl, sigma = generalize_goal_gen env sigma ids i o t cl in
+          (cl, sigma, args))
+	0 lconstr (concl, sigma, [])
     in
-      Proofview.Unsafe.tclEVARS sigma <*>
-	Proofview.Refine.refine begin fun sigma ->
-          let (sigma, ev) = Evarutil.new_evar env sigma ~principal:true newcl in
-            (sigma, (applist (ev, args)))
-	end
-  end
+    let tac =
+	Refine.refine { run = begin fun sigma ->
+          let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true newcl in
+          Sigma ((applist (ev, args)), sigma, p)
+	end }
+    in
+    Sigma.Unsafe.of_pair (tac, sigma)
+  end }
 
 let generalize_gen lconstr =
-  generalize_gen_let (List.map (fun ((occs,c),na) ->
+  generalize_gen_let (List.map (fun (occs_c,na) ->
+    let (occs,c) = Redexpr.out_with_occurrences occs_c in
     (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 -> ((AllOccurrences,c,None),Anonymous)) l)
 
-let new_generalize l =
+let 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 ?
@@ -2635,29 +2884,88 @@ let quantify lconstr =
    tclIDTAC
 *)
 
+(* Modifying/Adding an hypothesis  *)
+
+let specialize (c,lbind) ipat =
+  Proofview.Goal.enter { enter = begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in
+  let sigma, term =
+    if lbind == NoBindings then
+      let sigma = Typeclasses.resolve_typeclasses env sigma in
+      sigma, nf_evar sigma c
+    else
+      let clause = make_clenv_binding env sigma (c,Retyping.get_type_of env sigma 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_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 " ++
+
+          pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++
+	  str ".");
+      clause.evd, term in
+  let typ = Retyping.get_type_of env sigma term in
+  let tac =
+    match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with
+    | Var id when Id.List.mem id (Tacmach.New.pf_ids_of_hyps gl) ->
+      (* Like assert (id:=id args) but with the concept of specialization *)
+      let naming,tac =
+        prepare_intros false (IntroIdentifier id) MoveLast ipat in
+      let repl = do_replace (Some id) naming in
+      Tacticals.New.tclTHENFIRST
+        (assert_before_then_gen repl naming typ tac)
+	(exact_no_check term)
+    | _ ->
+      match ipat with
+      | None ->
+        (* Like generalize with extra support for "with" bindings *)
+        (* even though the "with" bindings forces full application *)
+        Tacticals.New.tclTHENLAST (cut typ) (exact_no_check term)
+      | Some (loc,ipat) ->
+        (* Like pose proof with extra support for "with" bindings *)
+        (* even though the "with" bindings forces full application *)
+        let naming,tac = prepare_intros_loc loc false IntroAnonymous MoveLast ipat in
+        Tacticals.New.tclTHENFIRST
+          (assert_before_then_gen false naming typ tac)
+	  (exact_no_check term)
+  in
+  Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) tac
+  end }
+
 (*****************************)
 (* Ad hoc unfold             *)
 (*****************************)
 
 (* The two following functions should already exist, but found nowhere *)
 (* Unfolds x by its definition everywhere *)
-let unfold_body x gl =
-  let hyps = pf_hyps gl in
-  let xval =
-    match Context.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 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 unfold_body x =
+  let open Context.Named.Declaration in
+  Proofview.Goal.enter { enter = begin fun gl ->
+  (** We normalize the given hypothesis immediately. *)
+  let env = Proofview.Goal.env (Proofview.Goal.assume gl) in
+  let xval = match Environ.lookup_named x env with
+  | LocalAssum _ -> errorlabstrm "unfold_body"
+    (pr_id x ++ str" is not a defined hypothesis.")
+  | LocalDef (_,xval,_) -> xval
+  in
+  Tacticals.New.afterHyp x begin fun aft ->
+  let hl = List.fold_right (fun decl cl -> (get_id decl, InHyp) :: cl) aft [] in
+  let rfun _ _ c = replace_vars [x, xval] c in
+  let reducth h = reduct_in_hyp rfun h in
+  let reductc = reduct_in_concl (rfun, DEFAULTcast) in
+  Tacticals.New.tclTHENLIST [Tacticals.New.tclMAP reducth hl; reductc]
+  end
+  end }
 
 (* Either unfold and clear if defined or simply clear if not a definition *)
-let expand_hyp id = tclTHEN (tclTRY (unfold_body id)) (clear [id])
+let expand_hyp id = Tacticals.New.tclTRY (unfold_body id) <*> clear [id]
 
 (*****************************)
 (* High-level induction      *)
@@ -2670,8 +2978,6 @@ let expand_hyp id = tclTHEN (tclTRY (unfold_body id)) (clear [id])
   - [hyp0] is the induction hypothesis
   - we extract from [args] the variables which are not rigid parameters
     of the inductive type, this is [indvars] (other terms are forgotten);
-    [indhyps] are the ones which actually are declared in context
-    (done in [find_atomic_param_of_ind])
   - we look for all hyps depending of [hyp0] or one of [indvars]:
     this is [dephyps] of types [deptyps] respectively
   - [statuslist] tells for each hyps in [dephyps] after which other hyp
@@ -2683,7 +2989,7 @@ let expand_hyp id = tclTHEN (tclTRY (unfold_body id)) (clear [id])
   Strategy: (cf in [induction_with_atomization_of_ind_arg])
   - requantify and clear all [dephyps]
   - apply induction on [hyp0]
-  - clear [indhyps] and [hyp0]
+  - clear those of [indvars] that are variables and [hyp0]
   - in the i-th subgoal, intro the arguments of the i-th constructor
     of the inductive type after [hyp0succ] (done in
     [induct_discharge]) let the induction hypotheses on top of the
@@ -2695,13 +3001,17 @@ let expand_hyp id = tclTHEN (tclTRY (unfold_body id)) (clear [id])
 
  *)
 
+let warn_unused_intro_pattern =
+  CWarnings.create ~name:"unused-intro-pattern" ~category:"tactics"
+         (fun names ->
+          strbrk"Unused introduction " ++ str (String.plural (List.length names) "pattern")
+          ++ str": " ++ prlist_with_sep spc 
+         (Miscprint.pr_intro_pattern 
+	 (fun c -> Printer.pr_constr (fst (run_delayed (Global.env()) Evd.empty c)))) names)
+
 let check_unused_names names =
   if not (List.is_empty names) && Flags.is_verbose () then
-    msg_warning
-      (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)
+    warn_unused_intro_pattern names
 
 let intropattern_of_name gl avoid = function
   | Anonymous -> IntroNaming IntroAnonymous
@@ -2731,19 +3041,19 @@ let re_intro_dependent_hypotheses (lstatus,rstatus) (_,tophyp) =
     (intros_move rstatus)
     (intros_move newlstatus)
 
-let dest_intro_patterns avoid thin dest pat tac =
-  intro_patterns_core true avoid [] thin dest None 0 tac pat
+let dest_intro_patterns with_evars avoid thin dest pat tac =
+  intro_patterns_core with_evars true avoid [] thin dest None 0 tac pat
 
-let safe_dest_intro_patterns avoid thin dest pat tac =
+let safe_dest_intro_patterns with_evars avoid thin dest pat tac =
   Proofview.tclORELSE
-    (dest_intro_patterns avoid thin dest pat tac)
+    (dest_intro_patterns with_evars 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
+          dest_intro_patterns with_evars avoid thin MoveLast pat tac
       | e -> Proofview.tclZERO ~info e
     end
 
@@ -2775,51 +3085,51 @@ 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 =
+let induct_discharge with_evars dests avoid' tac (avoid,ra) names =
   let avoid = avoid @ avoid' in
   let rec peel_tac ra dests names thin =
     match ra with
-    | (RecArg,deprec,recvarname) ::
-        (IndArg,depind,hyprecname) :: ra' ->
-        Proofview.Goal.enter begin fun gl ->
+    | (RecArg,_,deprec,recvarname) ::
+        (IndArg,_,depind,hyprecname) :: ra' ->
+        Proofview.Goal.enter { 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, IntroNaming (IntroIdentifier id')])
           | _ -> consume_pattern avoid (Name recvarname) deprec gl names in
         let dest = get_recarg_dest dests in
-        dest_intro_patterns avoid thin dest [recpat] (fun ids thin ->
-        Proofview.Goal.enter begin fun gl ->
+        dest_intro_patterns with_evars avoid thin dest [recpat] (fun ids thin ->
+        Proofview.Goal.enter { 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 ->
+	  dest_intro_patterns with_evars 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 ->
+        end })
+        end }
+    | (IndArg,_,dep,hyprecname) :: ra' ->
+        Proofview.Goal.enter { enter = begin fun gl ->
 	(* Rem: does not happen in Coq schemes, only in user-defined schemes *)
         let pat,names =
           consume_pattern avoid (Name hyprecname) dep gl names in
-	dest_intro_patterns avoid thin MoveLast [pat] (fun ids thin ->
+	dest_intro_patterns with_evars avoid thin MoveLast [pat] (fun ids thin ->
         peel_tac ra' (update_dest dests ids) names thin)
-        end
-    | (RecArg,dep,recvarname) :: ra' ->
-        Proofview.Goal.enter begin fun gl ->
+        end }
+    | (RecArg,_,dep,recvarname) :: ra' ->
+        Proofview.Goal.enter { enter = begin fun gl ->
         let (pat,names) =
           consume_pattern avoid (Name recvarname) dep gl names in
         let dest = get_recarg_dest dests in
-	dest_intro_patterns avoid thin dest [pat] (fun ids thin ->
+	dest_intro_patterns with_evars avoid thin dest [pat] (fun ids thin ->
         peel_tac ra' dests names thin)
-        end
-    | (OtherArg,dep,_) :: ra' ->
-        Proofview.Goal.enter begin fun gl ->
+        end }
+    | (OtherArg,_,dep,_) :: ra' ->
+        Proofview.Goal.enter { enter = begin fun gl ->
         let (pat,names) = consume_pattern avoid Anonymous dep gl names in
         let dest = get_recarg_dest dests in
-	safe_dest_intro_patterns avoid thin dest [pat] (fun ids thin ->
+	safe_dest_intro_patterns with_evars avoid thin dest [pat] (fun ids thin ->
         peel_tac ra' dests names thin)
-        end
+        end }
     | [] ->
         check_unused_names names;
         Tacticals.New.tclTHEN (clear_wildcards thin) (tac dests)
@@ -2831,6 +3141,7 @@ let induct_discharge dests avoid' tac (avoid,ra) names =
      substitutions aussi sur l'argument voisin *)
 
 let expand_projections env sigma c =
+  let sigma = Sigma.to_evar_map sigma in
   let rec aux env c =
     match kind_of_term c with
     | Proj (p, c) -> Retyping.expand_projection env sigma p (aux env c) []
@@ -2841,7 +3152,7 @@ let expand_projections env sigma c =
 (* Marche pas... faut prendre en compte l'occurrence précise... *)
 
 let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { 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
@@ -2894,7 +3205,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac =
 	      (atomize_one (i-1) (mkVar x::args) (mkVar x::args') (x::avoid))
   in
   atomize_one (List.length argl) [] [] []
-  end
+  end }
 
 (* [cook_sign] builds the lists [beforetoclear] (preceding the
    ind. var.) and [aftertoclear] (coming after the ind. var.)  of hyps
@@ -2918,7 +3229,6 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac =
 
    Induction hypothesis is H4 ([hyp0])
    Variable parameters of (le O n) is the singleton list with "n" ([indvars])
-   Part of [indvars] really in context is the same ([indhyps])
    The dependent hyps are H3 and H6 ([dephyps])
    For H3 the memorized places are H5 ([lhyp]) and H2 ([rhyp])
     because these names are among the hyp which are fixed through the induction
@@ -2963,8 +3273,9 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac =
 exception Shunt of Id.t move_location
 
 let cook_sign hyp0_opt inhyps indvars env =
-  (* First phase from L to R: get [indhyps], [decldep] and [statuslist]
+  (* First phase from L to R: get [toclear], [decldep] and [statuslist]
      for the hypotheses before (= more ancient than) hyp0 (see above) *)
+  let open Context.Named.Declaration in
   let toclear = ref [] in
   let avoid = ref [] in
   let decldeps = ref [] in
@@ -2973,7 +3284,8 @@ let cook_sign hyp0_opt inhyps indvars env =
   let lstatus = ref [] in
   let before = ref true in
   let maindep = ref false in
-  let seek_deps env (hyp,_,_ as decl) rhyp =
+  let seek_deps env decl rhyp =
+    let hyp = get_id decl in
     if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false)
     then begin
       before:=false;
@@ -2992,7 +3304,7 @@ let cook_sign hyp0_opt inhyps indvars env =
       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)
+         List.exists (fun decl' -> occur_var_in_decl env (get_id decl') decl) !decldeps)
       in
       if not (List.is_empty inhyps) && Id.List.mem hyp inhyps
          || dephyp0 || depother
@@ -3014,7 +3326,8 @@ let cook_sign hyp0_opt inhyps indvars env =
   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,_,_) =
+  let compute_lstatus lhyp decl =
+    let hyp = get_id decl in
     if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false) then
       raise (Shunt lhyp);
     if Id.List.mem hyp !ldeps then begin
@@ -3064,20 +3377,20 @@ type elim_scheme = {
   elimc: constr with_bindings option;
   elimt: types;
   indref: global_reference option;
-  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,...) *)
-  npredicates: int;        (* Number of predicates *)
-  branches: rel_context;   (* branchr,...,branch1 *)
-  nbranches: int;          (* Number of branches *)
-  args: rel_context;       (* (xni, Ti_ni) ... (x1, Ti_1) *)
-  nargs: int;              (* number of arguments *)
-  indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni)
-				     if HI is in premisses, None otherwise *)
-  concl: types;            (* Qi x1...xni HI (f...), HI and (f...)
-			      are optional and mutually exclusive *)
-  indarg_in_concl: bool;   (* true if HI appears at the end of conclusion *)
-  farg_in_concl: bool;     (* true if (f...) appears at the end of conclusion *)
+  params: Context.Rel.t;      (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *)
+  nparams: int;               (* number of parameters *)
+  predicates: Context.Rel.t;  (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *)
+  npredicates: int;           (* Number of predicates *)
+  branches: Context.Rel.t;    (* branchr,...,branch1 *)
+  nbranches: int;             (* Number of branches *)
+  args: Context.Rel.t;        (* (xni, Ti_ni) ... (x1, Ti_1) *)
+  nargs: int;                 (* number of arguments *)
+  indarg: Context.Rel.Declaration.t option; (* Some (H,I prm1..prmp x1...xni)
+                                               if HI is in premisses, None otherwise *)
+  concl: types;               (* Qi x1...xni HI (f...), HI and (f...)
+			         are optional and mutually exclusive *)
+  indarg_in_concl: bool;      (* true if HI appears at the end of conclusion *)
+  farg_in_concl: bool;        (* true if (f...) appears at the end of conclusion *)
 }
 
 let empty_scheme =
@@ -3197,31 +3510,36 @@ let decompose_indapp f args =
   | _ -> f, args
 
 let mk_term_eq env sigma ty t ty' t' =
+  let sigma = Sigma.to_evar_map sigma in
   if Reductionops.is_conv env sigma ty ty' then
     mkEq ty t t', mkRefl ty' t'
   else
     mkHEq ty t ty' t', mkHRefl ty' t'
 
-let make_abstract_generalize gl id concl dep ctx body c eqs args refls =
-  let meta = Evarutil.new_meta() in
+let make_abstract_generalize env id typ concl dep ctx body c eqs args refls =
+  let open Context.Rel.Declaration in
+  Refine.refine { run = begin fun sigma ->
   let eqslen = List.length eqs in
-  let term, typ = mkVar id, pf_get_hyp_typ gl id in
     (* Abstract by the "generalized" hypothesis equality proof if necessary. *)
   let abshypeq, abshypt =
     if dep then
-      let eq, refl = mk_term_eq (push_rel_context ctx (pf_env gl)) (project gl) (lift 1 c) (mkRel 1) typ term in
+      let eq, refl = mk_term_eq (push_rel_context ctx env) sigma (lift 1 c) (mkRel 1) typ (mkVar id) in
 	mkProd (Anonymous, eq, lift 1 concl), [| refl |]
     else concl, [||]
   in
     (* Abstract by equalities *)
   let eqs = lift_togethern 1 eqs in (* lift together and past genarg *)
-  let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> (Anonymous, None, x)) eqs) in
+  let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> LocalAssum (Anonymous, x)) eqs) in
+  let decl = match body with
+    | None -> LocalAssum (Name id, c)
+    | Some body -> LocalDef (Name id, body, c)
+  in
     (* Abstract by the "generalized" hypothesis. *)
-  let genarg = mkProd_or_LetIn (Name id, body, c) abseqs in
+  let genarg = mkProd_or_LetIn decl abseqs in
     (* Abstract by the extension of the context *)
   let genctyp = it_mkProd_or_LetIn genarg ctx in
     (* The goal will become this product. *)
-  let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in
+  let Sigma (genc, sigma, p) = Evarutil.new_evar env sigma ~principal:true genctyp in
     (* Apply the old arguments giving the proper instantiation of the hyp *)
   let instc = mkApp (genc, Array.of_list args) in
     (* Then apply to the original instantiated hyp. *)
@@ -3229,14 +3547,17 @@ let make_abstract_generalize gl id concl dep ctx body c eqs args refls =
     (* Apply the reflexivity proofs on the indices. *)
   let appeqs = mkApp (instc, Array.of_list refls) in
     (* Finally, apply the reflexivity proof for the original hyp, to get a term of type gl again. *)
-    mkApp (appeqs, abshypt)
+  Sigma (mkApp (appeqs, abshypt), sigma, p)
+  end }
 
 let hyps_of_vars env sign nogen hyps =
+  let open Context.Named.Declaration in
   if Id.Set.is_empty hyps then []
   else
     let (_,lh) =
-      Context.fold_named_context_reverse
-        (fun (hs,hl) (x,_,_ as d) ->
+      Context.Named.fold_inside
+        (fun (hs,hl) d ->
+          let x = get_id d in
 	  if Id.Set.mem x nogen then (hs,hl)
 	  else if Id.Set.mem x hs then (hs,x::hl)
 	  else
@@ -3265,14 +3586,15 @@ let linear vars args =
       true
     with Seen -> false
 
-let is_defined_variable env id = match lookup_named id env with
-| (_, None, _) -> false
-| (_, Some _, _) -> true
+let is_defined_variable env id =
+  let open Context.Named.Declaration in
+  lookup_named id env |> is_local_def
 
 let abstract_args gl generalize_vars dep id defined f args =
-  let sigma = ref (project gl) in
-  let env = pf_env gl in
-  let concl = pf_concl gl in
+  let open Context.Rel.Declaration in
+  let sigma = ref (Tacmach.project gl) in
+  let env = Tacmach.pf_env gl in
+  let concl = Tacmach.pf_concl gl in
   let dep = dep || dependent (mkVar id) concl in
   let avoid = ref [] in
   let get_id name =
@@ -3286,11 +3608,12 @@ let abstract_args gl generalize_vars dep id defined f args =
        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 =
-    let (name, _, ty), arity =
+    let name, ty, arity =
       let rel, c = Reductionops.splay_prod_n env !sigma 1 prod in
-	List.hd rel, c
+      let decl = List.hd rel in
+      get_name decl, get_type decl, c
     in
-    let argty = pf_unsafe_type_of gl arg in
+    let argty = Tacmach.pf_unsafe_type_of gl arg in
     let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in
     let () = sigma := sigma' in
     let lenctx = List.length ctx in
@@ -3302,7 +3625,7 @@ let abstract_args gl generalize_vars dep id defined f args =
       	  Id.Set.add id nongenvars, Id.Set.remove id vars, env)
       | _ ->
 	  let name = get_id name in
-	  let decl = (Name name, None, ty) in
+	  let decl = LocalAssum (Name name, ty) in
 	  let ctx = decl :: ctx in
 	  let c' = mkApp (lift 1 c, [|mkRel 1|]) in
 	  let args = arg :: args in
@@ -3331,7 +3654,7 @@ let abstract_args gl generalize_vars dep id defined f args =
 	      true, mkApp (f', before), after
   in
     if dogen then
-      let tyf' = pf_unsafe_type_of gl f' in
+      let tyf' = Tacmach.pf_unsafe_type_of gl f' in
       let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env =
 	Array.fold_left aux (tyf',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args'
       in
@@ -3343,23 +3666,25 @@ let abstract_args gl generalize_vars dep id defined f args =
 	else []
       in
       let body, c' =
-	if defined then Some c', typ_of ctxenv !sigma c'
+	if defined then Some c', Retyping.get_type_of ctxenv !sigma c'
 	else None, c'
       in
-      let term = make_abstract_generalize {gl with sigma = !sigma} id concl dep ctx body c' eqs args refls in
-	Some (term, !sigma, dep, succ (List.length ctx), vars)
+      let typ = Tacmach.pf_get_hyp_typ gl id in
+      let tac = make_abstract_generalize (pf_env gl) id typ concl dep ctx body c' eqs args refls in
+      let tac = Proofview.Unsafe.tclEVARS !sigma <*> tac in
+	Some (tac, dep, succ (List.length ctx), vars)
     else None
 
 let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id =
-  Proofview.Goal.nf_enter begin fun gl ->
+  let open Context.Named.Declaration in
+  Proofview.Goal.nf_enter { 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
+      match Tacmach.New.pf_get_hyp id gl with
+      | LocalAssum (_,t) -> let f, args = decompose_app t in
 	        (f, args, false, id, oldid)
-      | Some t ->
+      | LocalDef (_,t,_) ->
 	  let f, args = decompose_app t in
 	  (f, args, true, id, oldid)
   in
@@ -3369,35 +3694,34 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id =
     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 -> Proofview.tclUNIT ()
-      | Some (newc, sigma, dep, n, vars) ->
+      | Some (tac, dep, n, vars) ->
 	  let tac =
 	    if dep then
-	      Tacticals.New.tclTHENLIST
-		[Proofview.Unsafe.tclEVARS sigma;
-		 Proofview.V82.tactic (refine newc);
+              Tacticals.New.tclTHENLIST [
+                tac;
 		 rename_hyp [(id, oldid)]; Tacticals.New.tclDO n intro;
-		 Proofview.V82.tactic (generalize_dep ~with_let:true (mkVar oldid))]
-	    else Tacticals.New.tclTHENLIST
-		   [Proofview.Unsafe.tclEVARS sigma;
-		    Proofview.V82.tactic (refine newc);
-		    Proofview.V82.tactic (clear [id]);
+		 generalize_dep ~with_let:true (mkVar oldid)]
+            else Tacticals.New.tclTHENLIST [
+                    tac;
+		    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
+		 Tacticals.New.tclMAP (fun id ->
+		      Tacticals.New.tclTRY (generalize_dep ~with_let:true (mkVar id))) vars])
+  end }
 
 let rec compare_upto_variables x y =
   if (isVar x || isRel x) && (isVar y || isRel y) then true
   else compare_constr compare_upto_variables x y
 
 let specialize_eqs id gl =
-  let env = pf_env gl in
-  let ty = pf_get_hyp_typ gl id in
+  let open Context.Rel.Declaration in
+  let env = Tacmach.pf_env gl in
+  let ty = Tacmach.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
@@ -3424,15 +3748,14 @@ let specialize_eqs id gl =
 	    if in_eqs then acc, in_eqs, ctx, ty
 	    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)
+		aux false (LocalDef (na,e,t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b)
     | t -> acc, in_eqs, ctx, ty
   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) ->
-    match b with
-    | Some k when isEvar k -> (n,None,t)
-    | b -> decl) ctx'
+  let ctx'' = List.map (function
+    | LocalDef (n,k,t) when isEvar k -> LocalAssum (n,t)
+    | decl -> decl) ctx'
   in
   let ty' = it_mkProd_or_LetIn ty ctx'' in
   let acc' = it_mkLambda_or_LetIn acc ctx'' in
@@ -3441,17 +3764,16 @@ let specialize_eqs id gl =
   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
+	(Proofview.V82.of_tactic (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
-  else specialize_eqs id gl
+let specialize_eqs id = Proofview.Goal.nf_enter { enter = begin fun gl ->
+  let msg = str "Specialization not allowed on dependent hypotheses" in
+  Proofview.tclOR (clear [id])
+    (fun _ -> Tacticals.New.tclZEROMSG msg) >>= fun () ->
+    Proofview.V82.tactic (specialize_eqs id)
+end }
 
 let occur_rel n c =
   let res = not (noccurn n c) in
@@ -3466,18 +3788,19 @@ let occur_rel n c =
    We also return the conclusion.
 *)
 let decompose_paramspred_branch_args elimt =
-  let rec cut_noccur elimt acc2 : rel_context * rel_context * types =
+  let open Context.Rel.Declaration in
+  let rec cut_noccur elimt acc2 =
     match kind_of_term elimt with
       | Prod(nme,tpe,elimt') ->
 	  let hd_tpe,_ = decompose_app ((strip_prod_assum tpe)) in
 	  if not (occur_rel 1 elimt') && isRel hd_tpe
-	  then cut_noccur elimt' ((nme,None,tpe)::acc2)
+	  then cut_noccur elimt' (LocalAssum (nme,tpe)::acc2)
 	  else let acc3,ccl = decompose_prod_assum elimt in acc2 , acc3 , ccl
       | App(_, _) | Rel _ -> acc2 , [] , elimt
       | _ -> error_ind_scheme "" in
-  let rec cut_occur elimt acc1 : rel_context * rel_context * rel_context * types =
+  let rec cut_occur elimt acc1 =
     match kind_of_term elimt with
-      | Prod(nme,tpe,c) when occur_rel 1 c -> cut_occur c ((nme,None,tpe)::acc1)
+      | Prod(nme,tpe,c) when occur_rel 1 c -> cut_occur c (LocalAssum (nme,tpe)::acc1)
       | Prod(nme,tpe,c) -> let acc2,acc3,ccl = cut_noccur elimt [] in acc1,acc2,acc3,ccl
       | App(_, _) | Rel _ -> acc1,[],[],elimt
       | _ -> error_ind_scheme "" in
@@ -3519,6 +3842,7 @@ let exchange_hd_app subst_hd t =
 
    - finish to fill in the elim_scheme: indarg/farg/args and finally indref. *)
 let compute_elim_sig ?elimc elimt =
+  let open Context.Rel.Declaration in
   let params_preds,branches,args_indargs,conclusion =
     decompose_paramspred_branch_args elimt in
 
@@ -3552,8 +3876,8 @@ let compute_elim_sig ?elimc elimt =
     (* 3- Look at last arg: is it the indarg? *)
     ignore (
       match List.hd args_indargs with
-	| hiname,Some _,hi -> error_ind_scheme ""
-	| hiname,None,hi ->
+	| LocalDef (hiname,_,hi) -> error_ind_scheme ""
+	| LocalAssum (hiname,hi) ->
 	    let hi_ind, hi_args = decompose_app hi in
 	    let hi_is_ind = (* hi est d'un type globalisable *)
 	      match kind_of_term hi_ind with
@@ -3577,24 +3901,25 @@ let compute_elim_sig ?elimc elimt =
   with Exit -> (* Ending by computing indref: *)
     match !res.indarg with
       | None -> !res (* No indref *)
-      | Some ( _,Some _,_) -> error_ind_scheme ""
-      | Some ( _,None,ind) ->
+      | Some (LocalDef _) -> error_ind_scheme ""
+      | Some (LocalAssum (_,ind)) ->
 	  let indhd,indargs = decompose_app ind in
 	  try {!res with indref = Some (global_of_constr indhd) }
-	  with e when Errors.noncritical e ->
+	  with e when CErrors.noncritical e ->
             error "Cannot find the inductive type of the inductive scheme."
 
 let compute_scheme_signature scheme names_info ind_type_guess =
+  let open Context.Rel.Declaration in
   let f,l = decompose_app scheme.concl in
   (* Vérifier que les arguments de Qi sont bien les xi. *)
   let cond, check_concl =
     match scheme.indarg with
-      | Some (_,Some _,_) ->
+      | Some (LocalDef _) ->
 	  error "Strange letin, cannot recognize an induction scheme."
       | None -> (* Non standard scheme *)
 	  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 *)
+      | Some (LocalAssum (_,ind)) -> (* Standard scheme from an inductive type *)
 	  let indhd,indargs = decompose_app ind in
 	  let cond hd = Term.eq_constr hd indhd in
 	  let check_concl is_pred p =
@@ -3603,7 +3928,7 @@ let compute_scheme_signature scheme names_info ind_type_guess =
 	    let ind_is_ok =
 	      List.equal Term.eq_constr
 		(List.lastn scheme.nargs indargs)
-		(extended_rel_list 0 scheme.args) in
+		(Context.Rel.to_extended_list 0 scheme.args) in
 	    if not (ccl_arg_ok && ind_is_ok) then
 	      error_ind_scheme "the conclusion of"
 	  in (cond, check_concl)
@@ -3618,28 +3943,28 @@ let compute_scheme_signature scheme names_info ind_type_guess =
   let rec check_branch p c =
     match kind_of_term c with
       | Prod (_,t,c) ->
-	(is_pred p t, dependent (mkRel 1) c) :: check_branch (p+1) c
+	(is_pred p t, true, dependent (mkRel 1) c) :: check_branch (p+1) c
       | LetIn (_,_,_,c) ->
-	(OtherArg, dependent (mkRel 1) c) :: check_branch (p+1) c
+	(OtherArg, false, dependent (mkRel 1) c) :: check_branch (p+1) c
       | _ when is_pred p c == IndArg -> []
       | _ -> raise Exit
   in
   let rec find_branches p lbrch =
     match lbrch with
-      | (_,None,t)::brs ->
+      | LocalAssum (_,t) :: brs ->
 	(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))
+	     List.map (fun (b,is_assum,dep) ->
+	       (b,is_assum,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")
-      | (_,Some _,_)::_ -> error_ind_scheme "the branches of"
+      | LocalDef _ :: _ -> error_ind_scheme "the branches of"
       | [] -> check_concl is_pred p; []
   in
   Array.of_list (find_branches 0 (List.rev scheme.branches))
@@ -3661,21 +3986,26 @@ let guess_elim isrec dep s hyp0 gl =
   let evd, elimc =
     if isrec && not (is_nonrec (fst mind)) then find_ind_eliminator (fst mind) s gl
     else
+      let env = Tacmach.New.pf_env gl in
+      let sigma = Sigma.Unsafe.of_evar_map (Tacmach.New.project gl) in
       if use_dependent_propositions_elimination () && dep
       then
-	Tacmach.New.pf_apply build_case_analysis_scheme gl mind true s
+        let Sigma (ind, sigma, _) = build_case_analysis_scheme env sigma mind true s in
+        (Sigma.to_evar_map sigma, ind)
       else
-	Tacmach.New.pf_apply build_case_analysis_scheme_default gl mind s in
+        let Sigma (ind, sigma, _) = build_case_analysis_scheme_default env sigma mind s in
+        (Sigma.to_evar_map sigma, ind)
+  in
   let elimt = Tacmach.New.pf_unsafe_type_of gl elimc in
     evd, ((elimc, NoBindings), elimt), mkIndU mind
 
 let given_elim hyp0 (elimc,lbind as e) gl =
   let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in
   let ind_type_guess,_ = decompose_app ((strip_prod tmptyp0)) in
-  Proofview.Goal.sigma gl, (e, Tacmach.New.pf_unsafe_type_of gl elimc), ind_type_guess
+  Tacmach.New.project gl, (e, Tacmach.New.pf_unsafe_type_of gl elimc), ind_type_guess
 
 type scheme_signature =
-    (Id.t list * (elim_arg_kind * bool * Id.t) list) array
+    (Id.t list * (elim_arg_kind * bool * bool * Id.t) list) array
 
 type eliminator_source =
   | ElimUsing of (eliminator * types) * scheme_signature
@@ -3715,13 +4045,15 @@ let is_functional_induction elimc gl =
 (* Wait the last moment to guess the eliminator so as to know if we
    need a dependent one or not *)
 
-let get_eliminator elim dep s gl = match elim with
+let get_eliminator elim dep s gl =
+  let open Context.Rel.Declaration in
+  match elim with
   | ElimUsing (elim,indsign) ->
-      Proofview.Goal.sigma gl, (* bugged, should be computed *) true, elim, indsign
+      Tacmach.New.project gl, (* bugged, should be computed *) true, elim, indsign
   | ElimOver (isrec,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
+      let branchlengthes = List.map (fun d -> assert (is_local_assum d); pi1 (decompose_prod_letin (get_type d))) (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
@@ -3740,10 +4072,10 @@ let recolle_clenv i params args elimclause gl =
   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))
+    List.map_i (fun i id -> mkVar id , pf_get_hyp_typ id gl, lindmv.(i))
       0 params in
   let clauses_args =
-    List.map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(k+i))
+    List.map_i (fun i id -> mkVar id , pf_get_hyp_typ id gl, lindmv.(k+i))
       0 args in
   let clauses = clauses_params@clauses_args in
   (* iteration of clenv_fchain with all infos we have. *)
@@ -3753,7 +4085,7 @@ let recolle_clenv i params args elimclause gl =
       (* from_n (Some 0) means that x should be taken "as is" without
          trying to unify (which would lead to trying to apply it to
          evars if y is a product). *)
-      let indclause  = mk_clenv_from_n gl (Some 0) (x,y) in
+      let indclause  = Tacmach.New.of_old (fun gl -> mk_clenv_from_n gl (Some 0) (x,y)) gl in
       let elimclause' = clenv_fchain ~with_univs:false i acc indclause in
       elimclause')
     (List.rev clauses)
@@ -3763,59 +4095,69 @@ let recolle_clenv i params args 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 with_evars params indvars elim gl =
+let induction_tac with_evars params indvars elim =
+  Proofview.Goal.nf_enter { enter = begin fun 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 = contract_letin_in_lam_header elimc in
   let elimc = mkCast (elimc, DEFAULTcast, elimt) in
-  let elimclause =
-    pf_apply make_clenv_binding gl (elimc,elimt) lbindelimc in
+  let elimclause = 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 i params indvars elimclause gl in
   (* one last resolution (useless?) *)
-  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
+  let resolved = Tacmach.New.of_old (clenv_unique_resolver ~flags:(elim_flags ()) elimclause') gl in
+  enforce_prop_bound_names rename (Clenvtac.clenv_refine with_evars resolved)
+  end }
 
 (* 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_in_context hyp0 inhyps elim indvars names induct_tac =
-  Proofview.Goal.enter begin fun gl ->
-    let env = Proofview.Goal.env gl in
+let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_tac =
+  let open Context.Named.Declaration in
+  Proofview.Goal.s_enter { s_enter = begin fun gl ->
     let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    let sigma = Sigma.to_evar_map sigma 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 statuslists,lhyp0,toclear,deps,avoid,dep_in_hyps = cook_sign hyp0 inhyps indvars env in
+    let dep_in_concl = Option.cata (fun id -> occur_var env id concl) false hyp0 in
+    let dep = dep_in_hyps || dep_in_concl 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
+        (fun a decl -> if is_local_assum decl then (mkVar (get_id decl))::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
+    let branchletsigns =
+      let f (_,is_not_let,_,_) = is_not_let in
+      Array.map (fun (_,l) -> List.map f l) indsign in
+    let names = compute_induction_names branchletsigns names in
+    let tac =
     (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);
+        if deps = [] then Proofview.tclUNIT () else 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)
+        Tacticals.New.tclMAP expand_hyp toclear;
       ])
       (Array.map2
-         (induct_discharge lhyp0 avoid (re_intro_dependent_hypotheses statuslists))
+         (induct_discharge with_evars lhyp0 avoid
+            (re_intro_dependent_hypotheses statuslists))
          indsign names)
-  end
+    in
+    Sigma.Unsafe.of_pair (tac, sigma)
+  end }
 
 let induction_with_atomization_of_ind_arg isrec with_evars elim names hyp0 inhyps =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { 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
+    apply_induction_in_context with_evars (Some hyp0) inhyps (pi3 elim_info) indvars names
+      (fun elim -> induction_tac with_evars [] [hyp0] elim))
+  end }
 
 let msg_not_right_number_induction_arguments scheme =
   str"Not the right number of induction arguments (expected " ++
@@ -3832,7 +4174,7 @@ let msg_not_right_number_induction_arguments scheme =
    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 ->
+  Proofview.Goal.nf_enter { 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
@@ -3852,39 +4194,44 @@ let induction_without_atomization isrec with_evars elim names lid =
        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 [
+  let induct_tac elim = Tacticals.New.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 with_evars params realindvars elim
-  ]) in
+    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
+  apply_induction_in_context with_evars None [] elim indvars names induct_tac
+  end }
 
 (* assume that no occurrences are selected *)
-let clear_unselected_context id inhyps cls gl =
-  if occur_var (pf_env gl) id (pf_concl gl) &&
+let clear_unselected_context id inhyps cls =
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
+  let open Context.Named.Declaration in
+  if occur_var (Tacmach.New.pf_env gl) id (Tacmach.New.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) =
+      let to_erase d =
+        let id' = get_id d in
 	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
+	  let test id = occur_var_in_decl (Tacmach.New.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 ids = List.map_filter to_erase (Proofview.Goal.hyps gl) in
+      clear ids
+  | None -> Proofview.tclUNIT ()
+  end }
 
 let use_bindings env sigma elim must_be_closed (c,lbind) typ =
+  let sigma = Sigma.to_evar_map sigma in
   let typ =
     if elim == None then
       (* w/o an scheme, the term has to be applied at least until
@@ -3906,7 +4253,8 @@ let use_bindings env sigma elim must_be_closed (c,lbind) typ =
       if must_be_closed && occur_meta (clenv_value indclause) then
         error "Need a fully applied argument.";
       (* We lose the possibility of coercions in with-bindings *)
-      pose_all_metas_as_evars env indclause.evd (clenv_value indclause)
+      let (sigma, c) = pose_all_metas_as_evars env indclause.evd (clenv_value indclause) in
+      Sigma.Unsafe.of_pair (c, sigma)
     with e when catchable_exception e ->
     try find_clause (try_red_product env sigma typ)
     with Redelimination -> raise e in
@@ -3924,14 +4272,15 @@ let check_expected_type env sigma (elimc,bl) elimt =
   fun t -> Evarconv.e_cumul env (ref sigma) t u
 
 let check_enough_applied env sigma elim =
+  let sigma = Sigma.to_evar_map sigma in
   (* 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
+      let t,_ = decompose_app (whd_all env sigma u) in isInd t
   | Some elimc ->
-      let elimt = typ_of env sigma (fst elimc) in
+      let elimt = Retyping.get_type_of env sigma (fst elimc) in
       let scheme = compute_elim_sig ~elimc elimt in
       match scheme.indref with
       | None ->
@@ -3942,15 +4291,19 @@ let check_enough_applied env sigma elim =
           (* Last argument is supposed to be the induction argument *)
           check_expected_type env sigma elimc elimt
 
+let guard_no_unifiable = Proofview.guard_no_unifiable >>= function
+| None -> Proofview.tclUNIT ()
+| Some l -> Proofview.tclZERO (RefinerError (UnresolvedBindings l))
+
 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
+  Proofview.Goal.s_enter { s_enter = begin fun gl ->
   let sigma = Proofview.Goal.sigma gl in
+  let env = Proofview.Goal.env 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 false (c0,lbind) t0 in
+  let Sigma (c, sigma', p) = use_bindings env sigma elim false (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
@@ -3960,7 +4313,8 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim
       (* 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
+      let Sigma (c0, sigma, q) = finish_evar_resolution ~flags env sigma (pending,c0) in
+      let tac =
       (if isrec then
           (* Historically, induction has side conditions last *)
           Tacticals.New.tclTHENFIRST
@@ -3968,32 +4322,38 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim
           (* and destruct has side conditions first *)
           Tacticals.New.tclTHENLAST)
       (Tacticals.New.tclTHENLIST [
-        Proofview.Unsafe.tclEVARS sigma;
-        Proofview.Refine.refine ~unsafe:true (fun sigma ->
+        Refine.refine ~unsafe:true { run = begin fun sigma ->
           let b = not with_evars && with_eq != None in
-          let (sigma,c) = use_bindings env sigma elim b (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);
+          let Sigma (c, sigma, p) = use_bindings env sigma elim b (c0,lbind) t0 in
+          let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in
+          let Sigma (ans, sigma, q) = mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t) in
+          Sigma (ans, sigma, p +> q)
+        end };
+        if with_evars then Proofview.shelve_unifiable else guard_no_unifiable;
         if is_arg_pure_hyp
-        then Tacticals.New.tclTRY (Proofview.V82.tactic (thin [destVar c0]))
+        then Tacticals.New.tclTRY (clear [destVar c0])
         else Proofview.tclUNIT ();
         if isrec then Proofview.cycle (-1) else Proofview.tclUNIT ()
       ])
       tac
+      in
+      Sigma (tac, sigma, q)
 
-  | Some (sigma',c) ->
+  | Some (Sigma (c, sigma', q)) ->
       (* 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
+      let tac =
       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);
+        Refine.refine ~unsafe:true { run = begin fun sigma ->
+          mkletin_goal env sigma store with_eq true (id,lastlhyp,ccl,c) None
+        end };
         tac
       ]
-  end
+      in
+      Sigma (tac, sigma', p +> q)
+  end }
 
 let has_generic_occurrences_but_goal cls id env ccl =
   clause_with_generic_context_selection cls &&
@@ -4005,14 +4365,14 @@ let induction_gen clear_flag isrec with_evars elim
   let inhyps = match cls with
   | Some {onhyps=Some hyps} -> List.map (fun ((_,id),_) -> id) hyps
   | _ -> [] in
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { 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()))
+    isVar c && not (mem_named_context_val (destVar c) (Global.named_context_val ()))
     && lbind == NoBindings && not with_evars && Option.is_empty eqname
     && clear_flag == None
     && has_generic_occurrences_but_goal cls (destVar c) env ccl in
@@ -4025,7 +4385,7 @@ let induction_gen clear_flag isrec with_evars elim
        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))
+      (clear_unselected_context id inhyps cls)
       (induction_with_atomization_of_ind_arg
          isrec with_evars elim names id inhyps)
   else
@@ -4040,7 +4400,7 @@ let induction_gen clear_flag isrec with_evars elim
       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
+  end }
 
 (* Induction on a list of arguments. First make induction arguments
    atomic (using letins), then do induction. The specificity here is
@@ -4059,13 +4419,13 @@ let induction_gen_l isrec with_evars elim names lc =
       | [] -> Proofview.tclUNIT ()
       | c::l' ->
 	  match kind_of_term c with
-	    | Var id when not (mem_named_context id (Global.named_context()))
+	    | Var id when not (mem_named_context_val id (Global.named_context_val ()))
 		&& not with_evars ->
 		let _ = newlc:= id::!newlc in
 		atomize_list l'
 
 	    | _ ->
-                Proofview.Goal.enter begin fun gl ->
+                Proofview.Goal.enter { enter = begin fun gl ->
                 let type_of = Tacmach.New.pf_unsafe_type_of gl in
                 let x =
 		  id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in
@@ -4076,7 +4436,7 @@ let induction_gen_l isrec with_evars elim names lc =
 		Tacticals.New.tclTHEN
 		  (letin_tac None (Name id) c None allHypsAndConcl)
 		  (atomize_list newl')
-                end in
+                end } in
   Tacticals.New.tclTHENLIST
     [
       (atomize_list lc);
@@ -4093,33 +4453,28 @@ 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 ->
+    Proofview.Goal.nf_enter { enter = begin fun gl ->
     let env = Proofview.Goal.env gl in
-    let sigma = Proofview.Goal.sigma gl in
+    let sigma = Tacmach.New.project 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
+      let _,c = force_destruction_arg false env sigma c in
       onInductionArg
-	(fun _clear_flag (c,lbind) ->
-	  if lbind != NoBindings then
-	    error "'with' clause not supported here.";
-	  induction_gen_l isrec with_evars elim names [c,eqname]) c
+	(fun _clear_flag c ->
+	  induction_gen_l isrec with_evars elim names
+            [with_no_bindings 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
+    end }
   | _ ->
-    Proofview.Goal.enter begin fun gl ->
+    Proofview.Goal.enter { enter = begin fun gl ->
     let env = Proofview.Goal.env gl in
-    let sigma = Proofview.Goal.sigma gl in
+    let sigma = Tacmach.New.project gl in
     match elim with
     | None ->
       (* Several arguments, without "using" clause *)
@@ -4133,28 +4488,22 @@ let induction_destruct isrec with_evars (lc,elim) =
         (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 ->
+          Proofview.Goal.enter { enter = begin fun gl ->
           let env = Proofview.Goal.env gl in
-          let sigma = Proofview.Goal.sigma gl in      
+          let sigma = Tacmach.New.project gl in      
           onOpenInductionArg env sigma (fun clear_flag a ->
             induction_gen clear_flag false with_evars None (a,b) cl) a
-          end) l)
+          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 lc = List.map (on_pi1 (fun c -> snd (force_destruction_arg false env sigma c))) lc in
       let newlc =
         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? *)
           | _clear_flag,ElimOnConstr x ->
               if eqn <> None then error "'eqn' clause not supported here.";
-              (x,names)
+              (with_no_bindings x,names)
 	  | _ -> error "Don't know where to find some argument.")
 	  lc in
       (* Check that "as", if any, is given only on the last argument *)
@@ -4163,7 +4512,7 @@ let induction_destruct isrec with_evars (lc,elim) =
         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
+    end }
 
 let induction ev clr c l e =
   induction_gen clr true ev e 
@@ -4205,7 +4554,7 @@ let simple_destruct = function
  *)
 
 let elim_scheme_type elim t =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { 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 ->
@@ -4215,23 +4564,24 @@ let elim_scheme_type elim t =
             (clenv_meta_type clause mv) clause in
 	Clenvtac.res_pf clause' ~flags:(elim_flags ()) ~with_evars:false
     | _ -> anomaly (Pp.str "elim_scheme_type")
-  end
+  end }
 
 let elim_type t =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.s_enter { s_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
+  Sigma.Unsafe.of_pair (elim_scheme_type elimc t, evd)
+  end }
 
 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
+  Proofview.Goal.s_enter { s_enter = begin fun gl ->
+  let sigma = Proofview.Goal.sigma gl in
+  let env = Tacmach.New.pf_env gl in
+  let (ind,t) = reduce_to_atomic_ind env (Sigma.to_evar_map sigma) t in
+  let s = Tacticals.New.elimination_sort_of_goal gl in
+  let Sigma (elimc, evd, p) = build_case_analysis_scheme_default env sigma ind s in
+  Sigma (elim_scheme_type elimc t, evd, p)
+  end }
 
 
 (************************************************)
@@ -4244,14 +4594,14 @@ let (forward_setoid_reflexivity, setoid_reflexivity) = Hook.make ()
 
 let maybe_betadeltaiota_concl allowred gl =
   let concl = Tacmach.New.pf_nf_concl gl in
-  let sigma = Proofview.Goal.sigma gl in
+  let sigma = Tacmach.New.project gl in
   if not allowred then concl
   else
     let env = Proofview.Goal.env gl in
-    whd_betadeltaiota env sigma concl
+    whd_all env sigma concl
 
 let reflexivity_red allowred =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { 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). *)
@@ -4259,7 +4609,7 @@ let reflexivity_red allowred =
     match match_with_equality_type concl with
     | None -> Proofview.tclZERO NoEquationFound
     | Some _ -> one_constructor 1 NoBindings
-  end
+  end }
 
 let reflexivity =
   Proofview.tclORELSE
@@ -4301,7 +4651,7 @@ let match_with_equation c =
     Proofview.tclZERO NoEquationFound
 
 let symmetry_red allowred =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { 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). *)
@@ -4313,7 +4663,7 @@ let symmetry_red allowred =
         (convert_concl_no_check concl DEFAULTcast)
         (Tacticals.New.pf_constr_of_global eq_data.sym apply)
   | None,eq,eq_kind -> prove_symmetry eq eq_kind
-  end
+  end }
 
 let symmetry =
   Proofview.tclORELSE
@@ -4327,7 +4677,7 @@ let (forward_setoid_symmetry_in, setoid_symmetry_in) = Hook.make ()
 
 
 let symmetry_in id =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
   let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in
   let sign,t = decompose_prod_assum ctype in
   Proofview.tclORELSE
@@ -4345,7 +4695,7 @@ let symmetry_in id =
       | NoEquationFound -> Hook.get forward_setoid_symmetry_in id
       | e -> Proofview.tclZERO ~info e
     end
-  end
+  end }
 
 let intros_symmetry =
   Tacticals.New.onClause
@@ -4370,7 +4720,7 @@ let (forward_setoid_transitivity, setoid_transitivity) = Hook.make ()
 
 (* This is probably not very useful any longer *)
 let prove_transitivity hdcncl eq_kind t =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { enter = begin fun gl ->
   let (eq1,eq2) = match eq_kind with
   | MonomorphicLeibnizEq (c1,c2) ->
       mkApp (hdcncl, [| c1; t|]), mkApp (hdcncl, [| t; c2 |])
@@ -4378,7 +4728,7 @@ let prove_transitivity hdcncl eq_kind t =
       mkApp (hdcncl, [| typ; c1; t |]), mkApp (hdcncl, [| typ; t; c2 |])
   | HeterogenousEq (typ1,c1,typ2,c2) ->
       let env = Proofview.Goal.env gl in
-      let sigma = Proofview.Goal.sigma gl in
+      let sigma = Tacmach.New.project gl in
       let type_of = Typing.unsafe_type_of env sigma in
       let typt = type_of t in
         (mkApp(hdcncl, [| typ1; c1; typt ;t |]),
@@ -4390,10 +4740,10 @@ let prove_transitivity hdcncl eq_kind t =
 	  [ Tacticals.New.tclDO 2 intro;
 	    Tacticals.New.onLastHyp simplest_case;
 	    assumption ]))
-  end
+  end }
 
 let transitivity_red allowred t =
-  Proofview.Goal.enter begin fun gl ->
+  Proofview.Goal.enter { 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). *)
@@ -4410,7 +4760,7 @@ let transitivity_red allowred t =
       match t with
       | None -> Tacticals.New.tclZEROMSG (str"etransitivity not supported for this relation.")
       | Some t -> prove_transitivity eq eq_kind t
-  end
+  end }
 
 let transitivity_gen t =
   Proofview.tclORELSE
@@ -4430,28 +4780,80 @@ let intros_transitivity  n  = Tacticals.New.tclTHEN intros (transitivity_gen n)
    is solved by tac *)
 
 (** 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) -> 
+let interpretable_as_section_decl evd d1 d2 =
+  let open Context.Named.Declaration in
+  match d2, d1 with
+  | LocalDef _, LocalAssum _ -> false
+  | LocalDef (_,b1,t1), LocalDef (_,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
+  | LocalAssum (_,t1), d2 -> e_eq_constr_univs evd t1 (get_type d2)
+
+let rec decompose len c t accu =
+  let open Context.Rel.Declaration in
+  if len = 0 then (c, t, accu)
+  else match kind_of_term c, kind_of_term t with 
+  | Lambda (na, u, c), Prod (_, _, t) ->
+    decompose (pred len) c t (LocalAssum (na, u) :: accu)
+  | LetIn (na, b, u, c), LetIn (_, _, _, t) ->
+    decompose (pred len) c t (LocalDef (na, b, u) :: accu)
+  | _ -> assert false
+
+let rec shrink ctx sign c t accu =
+  let open Context.Rel.Declaration in
+  match ctx, sign with
+  | [], [] -> (c, t, accu)
+  | p :: ctx, decl :: sign ->
+      if noccurn 1 c && noccurn 1 t then
+        let c = subst1 mkProp c in
+        let t = subst1 mkProp t in
+        shrink ctx sign c t accu
+      else
+        let c = mkLambda_or_LetIn p c in
+        let t = mkProd_or_LetIn p t in
+        let accu = if is_local_assum p then let open Context.Named.Declaration in
+                                            mkVar (get_id decl) :: accu
+                                       else accu
+    in
+    shrink ctx sign c t accu
+| _ -> assert false
+
+let shrink_entry sign const =
+  let open Entries in
+  let typ = match const.const_entry_type with
+  | None -> assert false
+  | Some t -> t
+  in
+  (** The body has been forced by the call to [build_constant_by_tactic] *)
+  let () = assert (Future.is_over const.const_entry_body) in
+  let ((body, uctx), eff) = Future.force const.const_entry_body in
+  let (body, typ, ctx) = decompose (List.length sign) body typ [] in
+  let (body, typ, args) = shrink ctx sign body typ [] in
+  let const = { const with
+    const_entry_body = Future.from_val ((body, uctx), eff);
+    const_entry_type = Some typ;
+  } in
+  (const, args)
 
 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()
+  let open Context.Named.Declaration in
+  Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
+  let sigma = Proofview.Goal.sigma gl in
+  let current_sign = Global.named_context_val ()
   and global_sign = Proofview.Goal.hyps gl in
-  let evdref = ref (Proofview.Goal.sigma gl) in
+  let sigma = Sigma.to_evar_map sigma in
+  let evdref = ref sigma in
   let sign,secsign =
     List.fold_right
-      (fun (id,_,_ as d) (s1,s2) ->
-	if mem_named_context id current_sign &&
-          interpretable_as_section_decl evdref (Context.lookup_named id current_sign) d
+      (fun d (s1,s2) ->
+        let id = get_id d in
+	if mem_named_context_val id current_sign &&
+          interpretable_as_section_decl evdref (lookup_named_val 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
+	else (Context.Named.add d s1,s2))
+      global_sign (Context.Named.empty, empty_named_context_val) in
   let id = next_global_ident_away id (pf_ids_of_hyps gl) in
   let concl = it_mkNamedProd_or_LetIn (Proofview.Goal.concl gl) sign in
   let concl =
@@ -4474,13 +4876,22 @@ let abstract_subproof id gk tac =
        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
+    let (_, info) = CErrors.push src in
     iraise (e, info)
   in
+  let const, args =
+    if !shrink_abstract then shrink_entry sign const
+    else (const, List.rev (Context.Named.to_instance sign))
+  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.InternalTacticRequest ~local:true id decl in
+  let cst () =
+    (** do not compute the implicit arguments, it may be costly *)
+    let () = Impargs.make_implicit_args false in
+    (** ppedrot: seems legit to have abstracted subproofs as local*)
+    Declare.declare_constant ~internal:Declare.InternalTacticRequest ~local:true id decl
+  in
+  let cst = Impargs.with_implicit_protection cst () 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
@@ -4488,14 +4899,13 @@ let abstract_subproof id gk tac =
   let eff = private_con_of_con (Global.safe_env ()) cst in
   let effs = add_private 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))
+    exact_no_check (applist (lem, args))
   in
-  if not safe then Proofview.mark_as_unsafe <*> solve else solve
-  end
+  let tac = if not safe then Proofview.mark_as_unsafe <*> solve else solve in
+  Sigma.Unsafe.of_pair (tac, evd)
+  end }
 
 let anon_id = Id.of_string "anonymous"
 
@@ -4515,7 +4925,8 @@ let tclABSTRACT name_op tac =
   abstract_subproof s gk tac
 
 let unify ?(state=full_transparent_state) x y =
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
+  let sigma = Proofview.Goal.sigma gl in
   try
     let core_flags =
       { (default_unify_flags ()).core_unify_flags with
@@ -4527,22 +4938,18 @@ let unify ?(state=full_transparent_state) x y =
       merge_unify_flags = core_flags;
       subterm_unify_flags = { core_flags with modulo_delta = empty_transparent_state } }
     in
-    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
+    let sigma = Sigma.to_evar_map sigma in
+    let sigma = w_unify (Tacmach.New.pf_env gl) sigma Reduction.CONV ~flags x y in
+    Sigma.Unsafe.of_pair (Proofview.tclUNIT (), sigma)
+  with e when CErrors.noncritical e ->
+    Sigma.here (Tacticals.New.tclFAIL 0 (str"Not unifiable")) sigma
+  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 =
@@ -4560,17 +4967,24 @@ end
 module New = struct
   open Proofview.Notations
 
-  let exact_proof c = Proofview.V82.tactic (exact_proof c)
+  let exact_proof c = 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 onhyps =
+      (** We reduced everywhere in the hyps before 8.6 *)
+      if Flags.version_compare !Flags.compat_version Flags.V8_5 == 0
+      then None
+      else Some []
+    in
+    reduce
+      (Lazy {rBeta=true;rMatch=true;rFix=true;rCofix=true;
+	     rZeta=false;rDelta=false;rConst=[]})
+      {onhyps; concl_occs=AllOccurrences }
 
   let refine ?unsafe c =
-    Proofview.Refine.refine ?unsafe c <*>
+    Refine.refine ?unsafe c <*>
     reduce_after_refine
 end
diff --git a/tactics/tactics.mli b/tactics/tactics.mli
index c28cb521..fb033363 100644
--- a/tactics/tactics.mli
+++ b/tactics/tactics.mli
@@ -9,7 +9,6 @@
 open Loc
 open Names
 open Term
-open Context
 open Environ
 open Proof_type
 open Evd
@@ -22,26 +21,27 @@ open Unification
 open Misctypes
 open Locus
 
-(** Main tactics. *)
+(** Main tactics defined in ML. This file is huge and should probably be split
+    in more reasonable units at some point. Because of its size and age, the
+    implementation features various styles and stages of the proof engine.
+    This has to be uniformized someday. *)
 
 (** {6 General functions. } *)
 
-val is_quantified_hypothesis : Id.t -> goal sigma -> bool
+val is_quantified_hypothesis : Id.t -> ([`NF],'b) Proofview.Goal.t -> bool
 
 (** {6 Primitive tactics. } *)
 
 val introduction    : ?check:bool -> Id.t -> unit Proofview.tactic
-val refine          : constr -> tactic
 val convert_concl   : ?check:bool -> types -> cast_kind -> unit Proofview.tactic
-val convert_hyp     : ?check:bool -> named_declaration -> unit Proofview.tactic
+val convert_hyp     : ?check:bool -> Context.Named.Declaration.t -> 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 convert_hyp_no_check : Context.Named.Declaration.t -> unit Proofview.tactic
 val mutual_fix      :
-  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
+  Id.t -> int -> (Id.t * int * constr) list -> int -> unit Proofview.tactic
+val fix             : Id.t option -> int -> unit Proofview.tactic
+val mutual_cofix    : Id.t -> (Id.t * constr) list -> int -> unit Proofview.tactic
+val cofix           : Id.t option -> unit Proofview.tactic
 
 val convert         : constr -> constr -> unit Proofview.tactic
 val convert_leq     : constr -> constr -> unit Proofview.tactic
@@ -50,7 +50,7 @@ val convert_leq     : constr -> constr -> unit Proofview.tactic
 
 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 find_intro_names : Context.Rel.t -> goal sigma -> Id.t list
 
 val intro                : unit Proofview.tactic
 val introf               : unit Proofview.tactic
@@ -74,7 +74,7 @@ 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
+  bool -> quantified_hypothesis -> ([`NF],'b) Proofview.Goal.t -> int
 
 val intros_until         : quantified_hypothesis -> unit Proofview.tactic
 
@@ -94,7 +94,11 @@ val try_intros_until :
 
 val onInductionArg :
   (clear_flag -> constr with_bindings -> unit Proofview.tactic) ->
-    constr with_bindings induction_arg -> unit Proofview.tactic
+    constr with_bindings destruction_arg -> unit Proofview.tactic
+
+val force_destruction_arg : evars_flag -> env -> evar_map ->
+    delayed_open_constr_with_bindings destruction_arg ->
+    evar_map * constr with_bindings destruction_arg
 
 (** Tell if a used hypothesis should be cleared by default or not *)
 
@@ -102,85 +106,85 @@ val use_clear_hyp_by_default : unit -> bool
 
 (** {6 Introduction tactics with eliminations. } *)
 
-val intro_patterns : intro_patterns -> unit Proofview.tactic
-val intro_patterns_to : Id.t move_location -> intro_patterns ->
+val intro_patterns : evars_flag -> intro_patterns -> unit Proofview.tactic
+val intro_patterns_to : evars_flag -> Id.t move_location -> intro_patterns ->
   unit Proofview.tactic
-val intro_patterns_bound_to : int -> Id.t move_location -> intro_patterns ->
+val intro_patterns_bound_to : evars_flag -> int -> Id.t move_location -> intro_patterns ->
   unit Proofview.tactic
-val intro_pattern_to : Id.t move_location -> delayed_open_constr intro_pattern_expr ->
+val intro_pattern_to : evars_flag -> 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
+val intros_patterns : evars_flag -> intro_patterns -> unit Proofview.tactic
 
 (** {6 Exact tactics. } *)
 
 val assumption       : unit Proofview.tactic
-val exact_no_check   : constr -> tactic
-val vm_cast_no_check : constr -> tactic
-val native_cast_no_check : constr -> tactic
+val exact_no_check   : constr -> unit Proofview.tactic
+val vm_cast_no_check : constr -> unit Proofview.tactic
+val native_cast_no_check : constr -> unit Proofview.tactic
 val exact_check      : constr -> unit Proofview.tactic
-val exact_proof      : Constrexpr.constr_expr -> tactic
+val exact_proof      : Constrexpr.constr_expr -> unit Proofview.tactic
 
 (** {6 Reduction tactics. } *)
 
 type tactic_reduction = env -> evar_map -> constr -> constr
 
-type change_arg = patvar_map -> evar_map -> evar_map * constr
+type change_arg = patvar_map -> constr Sigma.run
 
 val make_change_arg   : constr -> change_arg
-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 reduct_in_hyp     : ?check:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic
+val reduct_option     : ?check:bool -> tactic_reduction * cast_kind -> goal_location -> unit Proofview.tactic
+val reduct_in_concl   : tactic_reduction * cast_kind -> unit Proofview.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
-val hnf_in_concl      : tactic
-val hnf_in_hyp        : hyp_location -> tactic
-val hnf_option        : goal_location -> tactic
-val simpl_in_concl    : tactic
-val simpl_in_hyp      : hyp_location -> tactic
-val simpl_option      : goal_location -> tactic
-val normalise_in_concl : tactic
-val normalise_in_hyp  : hyp_location -> tactic
-val normalise_option  : goal_location -> tactic
-val normalise_vm_in_concl : tactic
+val red_in_concl      : unit Proofview.tactic
+val red_in_hyp        : hyp_location -> unit Proofview.tactic
+val red_option        : goal_location -> unit Proofview.tactic
+val hnf_in_concl      : unit Proofview.tactic
+val hnf_in_hyp        : hyp_location -> unit Proofview.tactic
+val hnf_option        : goal_location -> unit Proofview.tactic
+val simpl_in_concl    : unit Proofview.tactic
+val simpl_in_hyp      : hyp_location -> unit Proofview.tactic
+val simpl_option      : goal_location -> unit Proofview.tactic
+val normalise_in_concl : unit Proofview.tactic
+val normalise_in_hyp  : hyp_location -> unit Proofview.tactic
+val normalise_option  : goal_location -> unit Proofview.tactic
+val normalise_vm_in_concl : unit Proofview.tactic
 val unfold_in_concl   :
-  (occurrences * evaluable_global_reference) list -> tactic
+  (occurrences * evaluable_global_reference) list -> unit Proofview.tactic
 val unfold_in_hyp     :
-  (occurrences * evaluable_global_reference) list -> hyp_location -> tactic
+  (occurrences * evaluable_global_reference) list -> hyp_location -> unit Proofview.tactic
 val unfold_option     :
-  (occurrences * evaluable_global_reference) list -> goal_location -> tactic
+  (occurrences * evaluable_global_reference) list -> goal_location -> unit Proofview.tactic
 val change            :
-  constr_pattern option -> change_arg -> clause -> tactic
+  constr_pattern option -> change_arg -> clause -> unit Proofview.tactic
 val pattern_option    :
-  (occurrences * constr) list -> goal_location -> tactic
-val reduce            : red_expr -> clause -> tactic
-val unfold_constr     : global_reference -> tactic
+  (occurrences * constr) list -> goal_location -> unit Proofview.tactic
+val reduce            : red_expr -> clause -> unit Proofview.tactic
+val unfold_constr     : global_reference -> unit Proofview.tactic
 
 (** {6 Modification of the local context. } *)
 
-val clear         : Id.t list -> tactic
+val clear         : Id.t list -> unit Proofview.tactic
 val clear_body    : Id.t list -> unit Proofview.tactic
-val unfold_body   : Id.t -> tactic
+val unfold_body   : Id.t -> unit Proofview.tactic
 val keep          : Id.t list -> unit Proofview.tactic
 val apply_clear_request : clear_flag -> bool -> constr -> unit Proofview.tactic
 
-val specialize    : constr with_bindings -> tactic
+val specialize    : constr with_bindings -> intro_pattern option -> unit Proofview.tactic
 
-val move_hyp      : Id.t -> Id.t move_location -> tactic
+val move_hyp      : Id.t -> Id.t move_location -> unit Proofview.tactic
 val rename_hyp    : (Id.t * Id.t) list -> unit Proofview.tactic
 
 val revert        : Id.t list -> unit Proofview.tactic
 
 (** {6 Resolution tactics. } *)
 
-val apply_type : constr -> constr list -> tactic
-val bring_hyps : named_context -> unit Proofview.tactic
+val apply_type : constr -> constr list -> unit Proofview.tactic
+val bring_hyps : Context.Named.t -> unit Proofview.tactic
 
 val apply                 : constr -> unit Proofview.tactic
 val eapply                : constr -> unit Proofview.tactic
@@ -206,6 +210,8 @@ val apply_delayed_in :
     (clear_flag * delayed_open_constr_with_bindings located) list ->
     intro_pattern option -> unit Proofview.tactic
 
+val run_delayed : Environ.env -> evar_map -> 'a delayed_open -> 'a * evar_map
+
 (** {6 Elimination tactics. } *)
 
 (*
@@ -237,20 +243,20 @@ type elim_scheme = {
   elimc: constr with_bindings option;
   elimt: types;
   indref: global_reference option;
-  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,...) *)
-  npredicates: int;        (** Number of predicates *)
-  branches: rel_context;   (** branchr,...,branch1 *)
-  nbranches: int;          (** Number of branches *)
-  args: rel_context;       (** (xni, Ti_ni) ... (x1, Ti_1) *)
-  nargs: int;              (** number of arguments *)
-  indarg: rel_declaration option; (** Some (H,I prm1..prmp x1...xni)
-				     if HI is in premisses, None otherwise *)
-  concl: types;            (** Qi x1...xni HI (f...), HI and (f...)
-			      are optional and mutually exclusive *)
-  indarg_in_concl: bool;   (** true if HI appears at the end of conclusion *)
-  farg_in_concl: bool;     (** true if (f...) appears at the end of conclusion *)
+  params: Context.Rel.t;      (** (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *)
+  nparams: int;               (** number of parameters *)
+  predicates: Context.Rel.t;  (** (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *)
+  npredicates: int;           (** Number of predicates *)
+  branches: Context.Rel.t;    (** branchr,...,branch1 *)
+  nbranches: int;             (** Number of branches *)
+  args: Context.Rel.t;        (** (xni, Ti_ni) ... (x1, Ti_1) *)
+  nargs: int;                 (** number of arguments *)
+  indarg: Context.Rel.Declaration.t option;  (** Some (H,I prm1..prmp x1...xni)
+	  		 	                 if HI is in premisses, None otherwise *)
+  concl: types;               (** Qi x1...xni HI (f...), HI and (f...)
+			          are optional and mutually exclusive *)
+  indarg_in_concl: bool;      (** true if HI appears at the end of conclusion *)
+  farg_in_concl: bool;        (** true if (f...) appears at the end of conclusion *)
 }
 
 val compute_elim_sig : ?elimc: constr with_bindings -> types -> elim_scheme
@@ -293,7 +299,7 @@ val destruct : evars_flag -> clear_flag -> constr -> or_and_intro_pattern option
 (** Implements user-level "destruct" and "induction" *)
 
 val induction_destruct : rec_flag -> evars_flag ->
-  (delayed_open_constr_with_bindings induction_arg
+  (delayed_open_constr_with_bindings destruction_arg
    * (intro_pattern_naming option * or_and_intro_pattern option)
    * clause option) list *
   constr with_bindings option -> unit Proofview.tactic
@@ -364,7 +370,7 @@ val pose_proof : Name.t -> constr ->
 
 (** Common entry point for user-level "assert", "enough" and "pose proof" *)
 
-val forward   : bool -> unit Proofview.tactic option ->
+val forward   : bool -> unit Proofview.tactic option option ->
   intro_pattern option -> constr -> unit Proofview.tactic
 
 (** Implements the tactic cut, actually a modus ponens rule *)
@@ -383,12 +389,12 @@ val letin_pat_tac : (bool * intro_pattern_naming) option ->
 
 (** {6 Generalize tactics. } *)
 
-val generalize      : constr list -> tactic
-val generalize_gen  : ((occurrences * constr) * Name.t) list -> tactic
-val new_generalize  : constr list -> unit Proofview.tactic
+val generalize      : constr list -> unit Proofview.tactic
+val generalize_gen  : (constr Locus.with_occurrences * Name.t) 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 generalize_dep  : ?with_let:bool (** Don't lose let bindings *) -> constr  -> unit Proofview.tactic
 
 (** {6 Other tactics. } *)
 
@@ -397,7 +403,7 @@ val unify           : ?state:Names.transparent_state -> constr -> constr -> unit
 val tclABSTRACT : Id.t option -> unit Proofview.tactic -> unit Proofview.tactic
 
 val abstract_generalize : ?generalize_vars:bool -> ?force_dep:bool -> Id.t -> unit Proofview.tactic
-val specialize_eqs : Id.t -> tactic
+val specialize_eqs : Id.t -> unit Proofview.tactic
 
 val general_rewrite_clause :
   (bool -> evars_flag -> constr with_bindings -> clause -> unit Proofview.tactic) Hook.t
@@ -416,9 +422,6 @@ 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
@@ -431,13 +434,11 @@ end
 
 module New : sig
 
-  val refine : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map*constr) -> unit Proofview.tactic
-  (** [refine ?unsafe c] is [Proofview.Refine.refine ?unsafe c]
+  val refine : ?unsafe:bool -> constr Sigma.run -> unit Proofview.tactic
+  (** [refine ?unsafe c] is [Refine.refine ?unsafe c]
       followed by beta-iota-reduction of the conclusion. *)
 
   val reduce_after_refine : unit Proofview.tactic
   (** The reducing tactic called after {!refine}. *)
 
-  open Proofview
-  val exact_proof : Constrexpr.constr_expr -> unit tactic
 end
diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib
index 2c5edc20..09330260 100644
--- a/tactics/tactics.mllib
+++ b/tactics/tactics.mllib
@@ -1,5 +1,3 @@
-Ftactic
-Geninterp
 Dnet
 Dn
 Btermdn
@@ -14,15 +12,11 @@ Equality
 Contradiction
 Inv
 Leminv
-Tacsubst
-Taccoerce
-Tacenv
 Hints
 Auto
-Tacintern
+Eauto
+Class_tactics
 Tactic_matching
-Tacinterp
-Evar_tactics
 Term_dnet
+Eqdecide
 Autorewrite
-Tactic_option
diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4
deleted file mode 100644
index f41fac54..00000000
--- a/tactics/tauto.ml4
+++ /dev/null
@@ -1,398 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \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 Term
-open Hipattern
-open Names
-open Pp
-open Genarg
-open Stdarg
-open Tacinterp
-open Tactics
-open Errors
-open Util
-
-DECLARE PLUGIN "tauto"
-
-let assoc_var s ist =
-  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 *)
-  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 *)
-  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 *)
-  strict_in_hyp_and_ccl : bool;
-
-(* Whether unit type includes equality types *)
-  strict_unit : bool;
-}
-
-(* Whether inner not are unfolded *)
-let negation_unfolding = ref true
-
-(* Whether inner iff are unfolded *)
-let iff_unfolding = ref false
-
-let unfold_iff () = !iff_unfolding || Flags.version_less_or_equal Flags.V8_2
-
-open Goptions
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      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>>
-  else
-    <:tactic<fail>>
-
-(* Strictly speaking, this exceeds the propositional fragment as it
-   matches also equality types (and solves them if a reflexivity) *)
-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
-    <:tactic<fail>>
-
-let is_record t =
-  let (hdapp,args) = decompose_app t in
-    match (kind_of_term hdapp) with
-      | Ind (ind,u) ->
-          let (mib,mip) = Global.lookup_inductive ind in
-	    mib.Declarations.mind_record <> None
-      | _ -> false
-
-let bugged_is_binary t =
-  isApp t &&
-  let (hdapp,args) = decompose_app t in
-    match (kind_of_term hdapp) with
-    | Ind (ind,u)  ->
-        let (mib,mip) = Global.lookup_inductive ind in
-         Int.equal mib.Declarations.mind_nparams 2
-    | _ -> false
-
-let iter_tac tacl =
-  List.fold_right (fun tac tacs -> <:tactic< $tac; $tacs >>) tacl
-
-(** Dealing with conjunction *)
-
-let is_conj flags ist =
-  let ind = assoc_var "X1" ist in
-    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 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:flags.strict_in_contravariant_hyp
-          ~onlybinary:flags.binary_mode typ
-  with
-  | Some (_,args) ->
-      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 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 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 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:flags.strict_in_contravariant_hyp
-          ~onlybinary:flags.binary_mode
-          typ with
-  | Some (_,args) ->
-      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>>
-
-
-(** Main tactic *)
-
-let not_dep_intros ist =
-  <:tactic<
-  repeat match goal with
-  | |- (forall (_: ?X1), ?X2) => intro
-  | |- (Coq.Init.Logic.not _) => unfold Coq.Init.Logic.not at 1; intro
-  end >>
-
-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; $c1
-      | _:?X1 |- _ => $t_is_empty; elimtype X1; assumption
-      | _:?X1 |- ?X1 => assumption
-    end >>
-
-
-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
-       (match reverse goal with
-        | id: ?X1 |- _ => $t_is_conj; elim id; do 2 intro; clear id
-        | 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: (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: forall (_ : ?X1), ?X2|- _ =>
-          $t_is_unit_or_eq; cut X2;
-	    [ intro; clear id
-	    | (* id : forall (_: ?X1), ?X2 |- ?X2 *)
-	      cut X1; [exact id| $c1; fail]
-	    ]
-        | id: forall (_ : ?X1), ?X2|- _ =>
-          $t_flatten_contravariant_conj
-	  (* moved from "id:(?A/\?B)->?X2|-" to "?A->?B->?X2|-" *)
-        | 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: forall (_:?X1), ?X2|- _ =>
-          $t_flatten_contravariant_disj
-	  (* moved from "id:(?A\/?B)->?X2|-" to "?A->?X2,?B->?X2|-" *)
-        | |- ?X1 => $t_is_conj; split
-        | |- (Coq.Init.Logic.iff _ _) => split
-        | |- (Coq.Init.Logic.not _) => red
-        end;
-        $t_not_dep_intros) >>
-
-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:forall(_: forall (_: ?X1), ?X2), ?X3|- _ =>
-	  cut X3;
-	    [ 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 ]]]
-      | 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]
-      end
-    ||
-    (* NB: [|- _ -> _] matches any product *)
-    match goal with | |- forall (_ : _),  _ => intro; t_tauto_intuit
-    |  |- _  => $t_reduce;t_solver
-    end
-    ||
-    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 _ ->
-          Tacticals.New.tclZEROMSG (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 (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 _ -> Tacticals.New.tclZEROMSG (str "Classical tauto failed.")
-      | e -> Proofview.tclZERO ~info e
-    end
-
-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 *)
-      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 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/test-suite/.csdp.cache b/test-suite/.csdp.cache
new file mode 100644
index 00000000..ba85286d
--- /dev/null
+++ b/test-suite/.csdp.cache
diff --git a/test-suite/Makefile b/test-suite/Makefile
index 207f25ed..c10cd4ed 100644
--- a/test-suite/Makefile
+++ b/test-suite/Makefile
@@ -49,6 +49,10 @@ 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)))))
+# get the command to use with this set of arguments; if there's -compile, use coqc, else use coqtop
+has_compile_flag = $(filter "-compile",$(call get_coq_prog_args,$(1)))
+has_profile_ltac_or_compile_flag = $(filter "-profile-ltac-cutoff" "-profile-ltac" "-compile",$(call get_coq_prog_args,$(1)))
+get_command_based_on_flags = $(if $(call has_profile_ltac_or_compile_flag,$(1)),$(coqc),$(command))
 
 
 bogomips:=
@@ -79,11 +83,14 @@ COMPLEXITY := $(if $(bogomips),complexity)
 BUGS := bugs/opened bugs/closed
 
 VSUBSYSTEMS := prerequisite success failure $(BUGS) output \
-  interactive micromega $(COMPLEXITY) modules stm
+  output-modulo-time interactive micromega $(COMPLEXITY) modules stm
 
 # All subsystems
 SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk
 
+PREREQUISITELOG = prerequisite/admit.v.log			\
+  prerequisite/make_local.v.log prerequisite/make_notation.v.log
+
 #######################################################################
 # Phony targets
 #######################################################################
@@ -92,13 +99,13 @@ SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk
 .PHONY: all run clean $(SUBSYSTEMS)
 
 all: run
-	$(MAKE) --quiet summary.log
+	$(MAKE) report
 
 run: $(SUBSYSTEMS)
 bugs: $(BUGS)
 
 clean:
-	rm -f trace lia.cache
+	rm -f trace .lia.cache
 	$(SHOW) "RM        <**/*.stamp> <**/*.vo> <**/*.vio> <**/*.log>"
 	$(HIDE)find . \( \
 	  -name '*.stamp' -o -name '*.vo' -o -name '*.vio' -o -name '*.log' \
@@ -133,6 +140,7 @@ summary:
 	  $(call summary_dir, "Failure tests", failure); \
 	  $(call summary_dir, "Bugs tests", bugs); \
 	  $(call summary_dir, "Output tests", output); \
+	  $(call summary_dir, "Output (modulo time changes) tests", output-modulo-time); \
 	  $(call summary_dir, "Interactive tests", interactive); \
 	  $(call summary_dir, "Micromega tests", micromega); \
 	  $(call summary_dir, "Miscellaneous tests", misc); \
@@ -151,11 +159,11 @@ summary:
 	}
 
 summary.log:
-	$(SHOW) SUMMARY
+	$(SHOW) BUILDING SUMMARY FILE
 	$(HIDE)$(MAKE) --quiet summary > "$@"
 
 report: summary.log
-	$(HIDE)if grep -F 'Error!' summary.log ; then false; fi
+	$(HIDE)if grep -q -F 'Error!' summary.log ; then echo FAILURES; grep -F 'Error!' summary.log; false; else echo NO FAILURES; fi
 
 #######################################################################
 # Regression (and progression) tests
@@ -172,7 +180,7 @@ $(addsuffix .log,$(wildcard bugs/opened/*.v)): %.v.log: %.v
 	@echo "TEST      $<  $(call get_coq_prog_args_in_parens,"$<")"
 	$(HIDE){ \
 	  echo $(call log_intro,$<); \
-	  $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \
+	  $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \
 	  if [ $$R = 0 ]; then \
 	    echo $(log_success); \
 	    echo "    $<...still active"; \
@@ -193,7 +201,7 @@ $(addsuffix .log,$(wildcard bugs/closed/*.v)): %.v.log: %.v
 	@echo "TEST      $< $(call get_coq_prog_args_in_parens,"$<")"
 	$(HIDE){ \
 	  echo $(call log_intro,$<); \
-	  $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \
+	  $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \
 	  if [ $$R = 0 ]; then \
 	    echo $(log_success); \
 	    echo "    $<...Ok"; \
@@ -221,12 +229,12 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v
 	  fi; \
 	} > "$@"
 
-$(addsuffix .log,$(wildcard success/*.v micromega/*.v modules/*.v)): %.v.log: %.v
+$(addsuffix .log,$(wildcard success/*.v micromega/*.v modules/*.v)): %.v.log: %.v $(PREREQUISITELOG)
 	@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; \
+	  $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") $$opts 2>&1; R=$$?; times; \
 	  if [ $$R = 0 ]; then \
 	    echo $(log_success); \
 	    echo "    $<...Ok"; \
@@ -242,7 +250,6 @@ $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v
 	$(HIDE){ \
 	  echo $(call log_intro,$<); \
 	  $(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); \
@@ -253,11 +260,11 @@ $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v
 	  fi; \
 	} > "$@"
 
-$(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v
+$(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v $(PREREQUISITELOG)
 	@echo "TEST      $< $(call get_coq_prog_args_in_parens,"$<")"
 	$(HIDE){ \
 	  echo $(call log_intro,$<); \
-	  $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \
+	  $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \
 	  if [ $$R = 0 ]; then \
 	    echo $(log_success); \
 	    echo "    $<...Ok"; \
@@ -267,16 +274,17 @@ $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v
 	  fi; \
 	} > "$@"
 
-$(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out
+$(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out $(PREREQUISITELOG)
 	@echo "TEST      $< $(call get_coq_prog_args_in_parens,"$<")"
 	$(HIDE){ \
 	  echo $(call log_intro,$<); \
 	  tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`; \
-	  $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1 \
+	  $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1 \
 	    | grep -v "Welcome to Coq" \
 	    | grep -v "\[Loading ML file" \
 	    | grep -v "Skipping rcfile loading" \
 	    | grep -v "^<W>" \
+	    | sed 's/File "[^"]*"/File "stdin"/' \
 	    > $$tmpoutput; \
 	  diff -u $*.out $$tmpoutput 2>&1; R=$$?; times; \
 	  if [ $$R = 0 ]; then \
@@ -289,7 +297,43 @@ $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out
 	  rm $$tmpoutput; \
 	} > "$@"
 
-$(addsuffix .log,$(wildcard interactive/*.v)): %.v.log: %.v
+$(addsuffix .log,$(wildcard output-modulo-time/*.v)): %.v.log: %.v %.out
+	@echo "TEST      $< $(call get_coq_prog_args_in_parens,"$<")"
+	$(HIDE){ \
+	  echo $(call log_intro,$<); \
+	  tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`; \
+	  tmpexpected=`mktemp /tmp/coqcheck.XXXXXX`; \
+	  $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1 \
+	    | grep -v "Welcome to Coq" \
+	    | grep -v "\[Loading ML file" \
+	    | grep -v "Skipping rcfile loading" \
+	    | grep -v "^<W>" \
+	    | sed -e 's/\s*[-+0-9]*\.[0-9][0-9]*\s*//g' \
+	          -e 's/\s*0\.\s*//g' \
+		  -e 's/\s*[-+]nan\s*//g' \
+		  -e 's/\s*[-+]inf\s*//g' \
+		  -e 's/^[^a-zA-Z]*//' \
+	    | sort \
+	    > $$tmpoutput; \
+	  sed -e 's/\s*[-+0-9]*\.[0-9][0-9]*\s*//g' \
+		-e 's/\s*0\.\s*//g' \
+		-e 's/\s*[-+]nan\s*//g' \
+		-e 's/\s*[-+]inf\s*//g' \
+		-e 's/^[^a-zA-Z]*//' \
+	       $*.out | sort > $$tmpexpected; \
+	  diff -b -u $$tmpexpected $$tmpoutput 2>&1; R=$$?; times; \
+	  if [ $$R = 0 ]; then \
+	    echo $(log_success); \
+	    echo "    $<...Ok"; \
+	  else \
+	    echo $(log_failure); \
+	    echo "    $<...Error! (unexpected output)"; \
+	  fi; \
+	  rm $$tmpoutput; \
+	  rm $$tmpexpected; \
+	} > "$@"
+
+$(addsuffix .log,$(wildcard interactive/*.v)): %.v.log: %.v $(PREREQUISITELOG)
 	@echo "TEST      $< $(call get_coq_prog_args_in_parens,"$<")"
 	$(HIDE){ \
 	  echo $(call log_intro,$<); \
@@ -307,12 +351,12 @@ $(addsuffix .log,$(wildcard interactive/*.v)): %.v.log: %.v
 # the .v file with exactly two digits after the dot. The reference for
 # time is a 6120 bogomips cpu.
 ifneq (,$(bogomips))
-$(addsuffix .log,$(wildcard complexity/*.v)): %.v.log: %.v
+$(addsuffix .log,$(wildcard complexity/*.v)): %.v.log: %.v $(PREREQUISITELOG)
 	@echo "TEST      $< $(call get_coq_prog_args_in_parens,"$<")"
 	$(HIDE){ \
 	  echo $(call log_intro,$<); \
 	  true "extract effective user time"; \
-	  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`; \
+	  res=`$(call get_command_based_on_flags,"$<") "$<" $(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); \
@@ -338,11 +382,11 @@ $(addsuffix .log,$(wildcard complexity/*.v)): %.v.log: %.v
 endif
 
 # Ideal-features tests
-$(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v
+$(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v $(PREREQUISITELOG)
 	@echo "TEST      $< $(call get_coq_prog_args_in_parens,"$<")"
 	$(HIDE){ \
 	  echo $(call log_intro,$<); \
-	  $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \
+	  $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \
 	  if [ $$R != 0 ]; then \
 	      echo $(log_success); \
 	      echo "    $<...still wished"; \
@@ -361,7 +405,7 @@ modules/%.vo: modules/%.v
 # Miscellaneous tests
 #######################################################################
 
-misc: misc/deps-order.log misc/universes.log
+misc: misc/deps-order.log misc/universes.log misc/deps-checksum.log
 
 # Check that both coqdep and coqtop/coqc supports -R
 # Check that both coqdep and coqtop/coqc takes the later -R
@@ -390,8 +434,28 @@ misc/deps-order.log:
 	  rm $$tmpoutput; \
 	} > "$@"
 
+deps-checksum: misc/deps-checksum.log
+misc/deps-checksum.log:
+	@echo "TEST      misc/deps-checksum"
+	$(HIDE){ \
+	  echo $(call log_intro,deps-checksum); \
+	  rm -f misc/deps/*/*.vo; \
+	  $(bincoqc) -R misc/deps/A A misc/deps/A/A.v; \
+	  $(bincoqc) -R misc/deps/B A misc/deps/B/A.v; \
+	  $(bincoqc) -R misc/deps/B A misc/deps/B/B.v; \
+	  $(coqtop) -R misc/deps/B A -R misc/deps/A A -load-vernac-source misc/deps/checksum.v 2>&1; \
+	  if [ $$? = 0 ]; then \
+	    echo $(log_success); \
+	    echo "    misc/deps-checksum...Ok"; \
+	  else \
+	    echo $(log_failure); \
+	    echo "    misc/deps-checksum...Error!"; \
+	  fi; \
+	} > "$@"
+
+
 # Sort universes for the whole standard library
-EXPECTED_UNIVERSES := 5
+EXPECTED_UNIVERSES := 4 # Prop is not counted
 universes: misc/universes.log
 misc/universes.log: misc/universes/all_stdlib.v
 	@echo "TEST      misc/universes"
@@ -422,7 +486,7 @@ ide : $(patsubst %.fake,%.fake.log,$(wildcard ide/*.fake))
 	@echo "TEST      $<"
 	$(HIDE){ \
 	  echo $(call log_intro,$<); \
-	  $(BIN)fake_ide $< "$(BIN)coqtop -boot -async-proofs on" 2>&1; \
+	  $(BIN)fake_ide $< "$(BIN)coqtop -boot -async-proofs on -async-proofs-tactic-error-resilience off -async-proofs-command-error-resilience off" 2>&1; \
 	  if [ $$? = 0 ]; then \
 	    echo $(log_success); \
 	    echo "    $<...Ok"; \
@@ -464,4 +528,3 @@ coqchk: $(patsubst %.v,%.chk.log,$(wildcard coqchk/*.v))
 	    echo "    $<...Error!"; \
 	  fi; \
 	} > "$@"
-
diff --git a/test-suite/bugs/4623.v b/test-suite/bugs/4623.v
new file mode 100644
index 00000000..405d0980
--- /dev/null
+++ b/test-suite/bugs/4623.v
@@ -0,0 +1,5 @@
+Goal Type -> Type.
+set (T := Type).
+clearbody T.
+refine (@id _).
+Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/4624.v b/test-suite/bugs/4624.v
new file mode 100644
index 00000000..a737afcd
--- /dev/null
+++ b/test-suite/bugs/4624.v
@@ -0,0 +1,7 @@
+Record foo := mkfoo { type : Type }.
+
+Canonical Structure fooA (T : Type) := mkfoo (T -> T).
+
+Definition id (t : foo) (x : type t) := x.
+
+Definition bar := id _ ((fun x : nat => x) : _).
\ No newline at end of file
diff --git a/test-suite/bugs/closed/1784.v b/test-suite/bugs/closed/1784.v
index 0b63d7b5..25d1b192 100644
--- a/test-suite/bugs/closed/1784.v
+++ b/test-suite/bugs/closed/1784.v
@@ -91,9 +91,8 @@ Next Obligation. intro H; inversion H. Defined.
 Next Obligation. intro H; inversion H; subst. Defined.
 Next Obligation.
   intro H1; contradict H. inversion H1; subst. assumption.
-  contradict H0; assumption. Defined.
-Next Obligation. 
-  intro H1; contradict H0. inversion H1; subst. assumption. Defined.
+  contradict H0; assumption.  Defined.
+Next Obligation. intro H1; contradict H0. inversion H1; subst. assumption. Defined.
 Next Obligation.
   intro H1; contradict H. inversion H1; subst. assumption. Defined.
 Next Obligation.
diff --git a/test-suite/bugs/closed/1850.v b/test-suite/bugs/closed/1850.v
new file mode 100644
index 00000000..26b48093
--- /dev/null
+++ b/test-suite/bugs/closed/1850.v
@@ -0,0 +1,4 @@
+Parameter P : Type -> Type -> Type.
+Notation      "e |= t --> v" := (P e t v)     (at level 100, t at level 54).
+Fail Check (nat |= nat --> nat).
+
diff --git a/test-suite/bugs/closed/2016.v b/test-suite/bugs/closed/2016.v
index 13ec5bea..536e6fab 100644
--- a/test-suite/bugs/closed/2016.v
+++ b/test-suite/bugs/closed/2016.v
@@ -1,6 +1,8 @@
 (* Coq 8.2beta4 *)
 Require Import Classical_Prop. 
 
+Unset Structural Injection.
+
 Record coreSemantics : Type := CoreSemantics {
   core: Type;
   corestep: core ->  core -> Prop;
@@ -49,7 +51,7 @@ unfold oe_corestep; intros.
 assert (HH:= step_fun _ _ _ H H0); clear H H0.
 destruct q1; destruct q2; unfold oe2coreSem; simpl in *.
 generalize (inj_pairT1 _ _ _ _ _ _ HH); clear HH; intros.
-injection H; clear H; intros.
+injection H.
 revert in_q1  in_corestep1 in_corestep_fun1
           H.
 pattern in_core1.
@@ -59,4 +61,4 @@ apply sym_eq.
 (** good to here **)
 Show Universes.
 Print Universes.
-Fail apply H0.
\ No newline at end of file
+Fail apply H0.
diff --git a/test-suite/bugs/closed/2021.v b/test-suite/bugs/closed/2021.v
index e598e5ae..5df92998 100644
--- a/test-suite/bugs/closed/2021.v
+++ b/test-suite/bugs/closed/2021.v
@@ -1,6 +1,8 @@
 (* correct failure of injection/discriminate on types whose inductive
    status derives from the substitution of an argument *)
 
+Unset Structural Injection.
+
 Inductive t : nat -> Type :=
 | M : forall n: nat, nat -> t n.
 
diff --git a/test-suite/bugs/closed/2310.v b/test-suite/bugs/closed/2310.v
index 0be859ed..7fae3287 100644
--- a/test-suite/bugs/closed/2310.v
+++ b/test-suite/bugs/closed/2310.v
@@ -14,4 +14,8 @@ 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)).
\ No newline at end of file
+  intros. Fail refine (Cons (cast H _ y)).
+  Unset Solve Unification Constraints. (* Keep the unification constraint around *)
+  refine (Cons (cast H _ y)).
+  intros.
+  refine (Nest (prod X X)). Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/opened/2800.v b/test-suite/bugs/closed/2800.v
index c559ab0c..2ee43893 100644
--- a/test-suite/bugs/opened/2800.v
+++ b/test-suite/bugs/closed/2800.v
@@ -1,6 +1,6 @@
 Goal False.
 
-Fail intuition
+intuition
   match goal with
   | |- _ => idtac " foo"
   end.
diff --git a/test-suite/bugs/closed/2839.v b/test-suite/bugs/closed/2839.v
index e396fe06..e727e260 100644
--- a/test-suite/bugs/closed/2839.v
+++ b/test-suite/bugs/closed/2839.v
@@ -5,6 +5,6 @@ intro.
 Fail
   let H :=
     match goal with
-    | [ H : appcontext G [@eq _ _] |- _ ] => let H' := context G[@plus 2] in H'
+    | [ H : context G [@eq _ _] |- _ ] => let H' := context G[@plus 2] in H'
     end
   in pose H.
diff --git a/test-suite/bugs/closed/2848.v b/test-suite/bugs/closed/2848.v
index de137d39..828e3b8c 100644
--- a/test-suite/bugs/closed/2848.v
+++ b/test-suite/bugs/closed/2848.v
@@ -2,8 +2,9 @@ Require Import Setoid.
 
 Parameter value' : Type.
 Parameter equiv' : value' -> value' -> Prop.
-
+Axiom cheat : forall {A}, A.
 Add Parametric Relation : _ equiv'
-  reflexivity proved by (Equivalence.equiv_reflexive _)
-  transitivity proved by (Equivalence.equiv_transitive _)
+  reflexivity proved by (Equivalence.equiv_reflexive cheat)
+  transitivity proved by (Equivalence.equiv_transitive cheat)
     as apply_equiv'_rel.
+Check apply_equiv'_rel : PreOrder equiv'.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3045.v b/test-suite/bugs/closed/3045.v
index ef110ad0..5f80013d 100644
--- a/test-suite/bugs/closed/3045.v
+++ b/test-suite/bugs/closed/3045.v
@@ -12,7 +12,7 @@ Record SpecializedCategory (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.
+Arguments Compose {obj} [C s d d'] _ _ : 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'.
diff --git a/test-suite/bugs/closed/3068.v b/test-suite/bugs/closed/3068.v
index ced6d959..79671ce9 100644
--- a/test-suite/bugs/closed/3068.v
+++ b/test-suite/bugs/closed/3068.v
@@ -56,7 +56,7 @@ Section Finite_nat_set.
       subst fs1.
       apply iff_refl.
     intros H.
-    eapply counted_list_equal_nth_char.
+    eapply (counted_list_equal_nth_char _ _ _ _ ?[def]).
     intros i.
     destruct (counted_def_nth fs1 i _ ) eqn:H0.
     (* This was not part of the initial bug report; this is to check that
diff --git a/test-suite/bugs/closed/3070.v b/test-suite/bugs/closed/3070.v
new file mode 100644
index 00000000..7a8feca5
--- /dev/null
+++ b/test-suite/bugs/closed/3070.v
@@ -0,0 +1,6 @@
+(* Testing subst wrt chains of dependencies *)
+
+Lemma foo (a1 a2 : Set) (b1 : a1 -> Prop)
+      (Ha : a1 = a2) (c : a1) (d : b1 c) : True.
+Proof.
+  subst.
diff --git a/test-suite/bugs/closed/3080.v b/test-suite/bugs/closed/3080.v
new file mode 100644
index 00000000..7d0dc090
--- /dev/null
+++ b/test-suite/bugs/closed/3080.v
@@ -0,0 +1,18 @@
+(* -*- coq-prog-args: ("-emacs" "-nois") -*- *)
+Delimit Scope type_scope with type.
+Delimit Scope function_scope with function.
+
+Bind Scope type_scope with Sortclass.
+Bind Scope function_scope with Funclass.
+
+Reserved Notation "x -> y" (at level 99, right associativity, y at level 200).
+Notation "A -> B" := (forall (_ : A), B) : type_scope.
+
+Definition compose {A B C} (g : B -> C) (f : A -> B) :=
+  fun x : A => g (f x).
+
+Notation " g ∘ f " := (compose g f)
+  (at level 40, left associativity) : function_scope.
+
+Fail Check (fun x => x) ∘ (fun x => x). (* this [Check] should fail, as [function_scope] is not opened *)
+Check compose ((fun x => x) ∘ (fun x => x)) (fun x => x). (* this check should succeed, as [function_scope] should be automatically bound in the arugments to [compose] *)
diff --git a/test-suite/bugs/closed/3209.v b/test-suite/bugs/closed/3209.v
new file mode 100644
index 00000000..855058b0
--- /dev/null
+++ b/test-suite/bugs/closed/3209.v
@@ -0,0 +1,75 @@
+(* Avoiding some occur-check *)
+
+(* 1. Original example *)
+
+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).
+
+(* 2. Alternative example by Guillaume *)
+
+Inductive foo (A : Prop) : Prop := Foo : foo A.
+Axiom bar : forall (A : Prop) (P : foo A -> Prop), (A -> P (Foo A)) -> Prop.
+
+(* This used to fail with a Not_found, we fail more graciously but a
+   heuristic could be implemented, e.g. in some smart occur-check
+   function, to find a solution of then form ?P := fun _ => ?P' *)
+
+Fail Check (fun e : ?[T] => bar ?[A] ?[P] (fun g : ?[A'] => g e)).
+
+(* This works and tells which solution we could have inferred *)
+
+Check (fun e : ?[T] => bar ?[A] (fun _ => ?[P]) (fun g : ?[A'] => g e)).
+
+(* For the record, here is the trace in the failing example:
+
+In (fun e : ?T => bar ?[A] ?[P] (fun g : ?A' => g e)), we have the existential variables
+
+e:?T |- ?A : Prop
+e:?T |- ?P : foo ?A -> Prop
+e:?T |- ?A' : Type
+
+with constraints
+
+?A' == ?A
+?A' == ?T -> ?P (Foo ?A)
+
+To type (g e), unification first defines
+
+?A := forall x:?B, ?P'{e:=e,x:=x}
+with ?T <= ?B
+and ?P'@{e:=e,x:=e} <= ?P@{e:=e} (Foo (forall x:?B, ?P'{e:=e,x:=x}))
+
+Then, since ?P'@{e:=e,x:=e} may use "e" in two different ways, it is
+not a pattern and we define a new
+
+e:?T x:?B|- ?P'' : foo (?B' -> ?P''') -> Prop
+
+for some ?B' and ?P''', together with
+
+?P'@{e,x} := ?P''{e:=e,x:=e} (Foo (?B -> ?P')
+?P@{e} := ?P''{e:=e,x:=e}
+
+Moreover, ?B' and ?P''' have to satisfy
+
+?B'@{e:=e,x:=e} == ?B@{e:=e}
+?P'''@{e:=e,x:=e} == ?P'@{e:=e,x:=x}
+
+and this leads to define ?P' which was the initial existential
+variable to define.
+*)
+
diff --git a/test-suite/bugs/closed/3251.v b/test-suite/bugs/closed/3251.v
index 5a7ae200..d4ce050c 100644
--- a/test-suite/bugs/closed/3251.v
+++ b/test-suite/bugs/closed/3251.v
@@ -1,4 +1,5 @@
 Goal True.
+idtac.
 Ltac foo := idtac.
 (* print out happens twice:
 foo is defined
diff --git a/test-suite/bugs/closed/3383.v b/test-suite/bugs/closed/3383.v
new file mode 100644
index 00000000..25257644
--- /dev/null
+++ b/test-suite/bugs/closed/3383.v
@@ -0,0 +1,6 @@
+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.
+lazymatch goal with
+| [ |- context[match ?b as b' in bool return @?P b' with true => ?t | false => ?f end] ]
+  => change (match b as b' in bool return P b' with true => t | false => f end) with (@bool_rect P t f b)
+end.
diff --git a/test-suite/bugs/closed/3424.v b/test-suite/bugs/closed/3424.v
index f9b2c386..ee8cabf1 100644
--- a/test-suite/bugs/closed/3424.v
+++ b/test-suite/bugs/closed/3424.v
@@ -13,6 +13,7 @@ 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).
+Set Refolding Reduction.
 Goal forall (A : Type) (a b : A) (H' : IsHSet A), { x : Type & IsHProp x }.
 Proof.
 intros.
diff --git a/test-suite/bugs/closed/3441.v b/test-suite/bugs/closed/3441.v
new file mode 100644
index 00000000..50d29780
--- /dev/null
+++ b/test-suite/bugs/closed/3441.v
@@ -0,0 +1,23 @@
+Axiom f : nat -> nat -> nat.
+Fixpoint do_n (n : nat) (k : nat) :=
+  match n with
+    | 0 => k
+    | S n' => do_n n' (f k k)
+  end.
+
+Notation big := (_ = _).
+Axiom k : nat.
+Goal True.
+Timeout 1 let H := fresh "H" in
+     let x := constr:(let n := 17 in do_n n = do_n n) in
+     let y := (eval lazy in x) in 
+     pose proof y as H. (* Finished transaction in 1.102 secs (1.084u,0.016s) (successful) *)
+Timeout 1 let H := fresh "H" in
+     let x := constr:(let n := 17 in do_n n = do_n n) in
+     let y := (eval lazy in x) in
+     pose y as H; clearbody H. (* Finished transaction in 0.412 secs (0.412u,0.s) (successful) *)
+
+Timeout 1 Time let H := fresh "H" in
+     let x := constr:(let n := 17 in do_n n = do_n n) in
+     let y := (eval lazy in x) in
+     assert (H := y). (* Finished transaction in 1.19 secs (1.164u,0.024s) (successful) *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3495.v b/test-suite/bugs/closed/3495.v
new file mode 100644
index 00000000..102a2aba
--- /dev/null
+++ b/test-suite/bugs/closed/3495.v
@@ -0,0 +1,18 @@
+Require Import RelationClasses.
+
+Axiom R : Prop -> Prop -> Prop.
+Declare Instance : Reflexive R.
+
+Class bar := { x : False }.
+Record foo := { a : Prop ; b : bar }.
+
+Definition default_foo (a0 : Prop) `{b : bar} : foo := {| a := a0 ; b := b |}.
+
+Goal exists k, R k True.
+Proof.
+eexists.
+evar (b : bar).
+let e := match goal with |- R ?e _ => constr:(e) end in
+unify e (a (default_foo True)).
+subst b.
+reflexivity.
diff --git a/test-suite/bugs/closed/3513.v b/test-suite/bugs/closed/3513.v
index fcdfa005..9ed0926a 100644
--- a/test-suite/bugs/closed/3513.v
+++ b/test-suite/bugs/closed/3513.v
@@ -1,4 +1,3 @@
-Require Import TestSuite.admit.
 (* File reduced by coq-bug-finder from original input, then from 5752 lines to 3828 lines, then from 2707 lines to 558 lines, then from 472 lines to 168 lines, then from 110 lines to 101 lines, then from 96 lines to 77 lines, then from 80 lines to 64 lines *)
 Require Coq.Setoids.Setoid.
 Import Coq.Setoids.Setoid.
@@ -35,7 +34,7 @@ Local Existing Instance ILFun_Ops.
 Local Existing Instance ILFun_ILogic.
 Definition catOP (P Q: OPred) : OPred := admit.
 Add Parametric Morphism : catOP with signature lentails ==> lentails ==> lentails as catOP_entails_m.
-admit.
+apply admit.
 Defined.
 Definition catOPA (P Q R : OPred) : catOP (catOP P Q) R -|- catOP P (catOP Q R) := admit.
 Class IsPointed (T : Type) := point : T.
@@ -69,8 +68,27 @@ Goal forall (T : Type) (O0 : T -> OPred) (O1 : T -> PointedOPred)
     pose P;
     refine (P _ _)
   end; unfold Basics.flip.
-  2: solve [ apply reflexivity ].
-  Undo.
-  2: reflexivity. (* Toplevel input, characters 18-29:
-Error:
-Tactic failure: The relation lentails is not a declared reflexive relation. Maybe you need to require the Setoid library. *)
\ No newline at end of file
+  Focus 2.
+  Set Typeclasses Debug.
+  Set Typeclasses Legacy Resolution.
+  apply reflexivity.
+  (* Debug: 1.1: apply @IsPointed_catOP on
+(IsPointed (exists x0 : Actions, (catOP ?Goal O2 : OPred) x0))
+Debug: 1.1.1.1: apply OPred_inhabited on (IsPointed (exists x0 : Actions, ?Goal x0))
+Debug: 1.1.2.1: apply OPred_inhabited on (IsPointed (exists x : Actions, O2 x))
+Debug: 2.1: apply @Equivalence_Reflexive on (Reflexive lentails)
+Debug: 2.1.1: no match for (Equivalence lentails) , 5 possibilities
+Debug: Backtracking after apply @Equivalence_Reflexive
+Debug: 2.2: apply @PreOrder_Reflexive on (Reflexive lentails)
+Debug: 2.2.1.1: apply @lentailsPre on (PreOrder lentails)
+Debug: 2.2.1.1.1.1: apply ILFun_ILogic on (ILogic OPred)
+*)
+  Undo. Unset Typeclasses Legacy Resolution.
+  Test Typeclasses Unique Solutions.
+  Test Typeclasses Unique Instances.
+  Show Existentials.
+  Set Typeclasses Debug Verbosity 2.
+  Set Printing All.
+  (* As in 8.5, allow a shelved subgoal to remain *)
+  apply reflexivity.
+  
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3563.v b/test-suite/bugs/closed/3563.v
index 67972166..961563ed 100644
--- a/test-suite/bugs/closed/3563.v
+++ b/test-suite/bugs/closed/3563.v
@@ -16,11 +16,11 @@ Goal forall (H H0 H1 : Type) (H2 : H1) (H3 : H1 -> H * H0)
        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] ]
+    | [ |- context 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))))] ]
+    | [ |- context ctx [transport (fun y => (?g (fst (y H2))))] ]
       => idtac
   end.
 Abort.
@@ -30,7 +30,7 @@ Goal forall (H H0 H1 : Type) (H2 : H1) (H3 : H1 -> (H1 -> H) * H0)
        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)))] ]
+    | [ |- context ctx [transport (fun y => (?g (@fst ?C ?D (y H2) ?X)))] ]
       => set(foo:=X)
   end.
 (* Anomaly: Uncaught exception Not_found(_). Please report. *)
diff --git a/test-suite/bugs/closed/3612.v b/test-suite/bugs/closed/3612.v
index 9125ab16..a5476850 100644
--- a/test-suite/bugs/closed/3612.v
+++ b/test-suite/bugs/closed/3612.v
@@ -6,6 +6,8 @@ lines, then from 421 lines to 428 lines, then from 444 lines to 429 lines, then
 Reserved Notation "x -> y" (at level 99, right associativity, y at level 200).
 Reserved Notation "x = y  :>  T" (at level 70, y at next level, no associativity).
 Reserved Notation "x = y" (at level 70, no associativity).
+Delimit Scope type_scope with type.
+Bind Scope type_scope with Sortclass.
 Open Scope type_scope.
 Global Set Universe Polymorphism.
 Notation "A -> B" := (forall (_ : A), B) : type_scope.
@@ -35,6 +37,9 @@ Axiom path_path_sigma : forall {A : Type} (P : A -> Type) (u v : sigT P)
            (r : p..1 = q..1)
            (s : transport (fun x => transport P x u.2 = v.2) r p..2 = q..2),
 p = q.
+
+Declare ML Module "coretactics".
+
 Goal forall (A : Type) (B : forall _ : A, Type) (x : @sigT A (fun x : A => B x))
             (xx : @paths (@sigT A (fun x0 : A => B x0)) x x),
        @paths (@paths (@sigT A (fun x0 : A => B x0)) x x) xx
diff --git a/test-suite/bugs/closed/3647.v b/test-suite/bugs/closed/3647.v
index 495e67e0..f5a22bd5 100644
--- a/test-suite/bugs/closed/3647.v
+++ b/test-suite/bugs/closed/3647.v
@@ -650,4 +650,5 @@ Goal    forall (ptest : program) (cond : Condition) (value : bool)
 
   Grab Existential Variables.
   subst_body; simpl.
-  refine (all_behead (projT2 _)).
+  Fail refine (all_behead (projT2 _)).
+  Unset Solve Unification Constraints. refine (all_behead (projT2 _)).
diff --git a/test-suite/bugs/closed/3649.v b/test-suite/bugs/closed/3649.v
index 06188e7b..fc4c171e 100644
--- a/test-suite/bugs/closed/3649.v
+++ b/test-suite/bugs/closed/3649.v
@@ -2,8 +2,11 @@
 (* File reduced by coq-bug-finder from original input, then from 9518 lines to 404 lines, then from 410 lines to 208 lines, then from 162 lines to 77 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) *)
+Declare ML Module "coretactics".
 Reserved Notation "x -> y" (at level 99, right associativity, y at level 200).
 Reserved Notation "x = y" (at level 70, no associativity).
+Delimit Scope type_scope with type.
+Bind Scope type_scope with Sortclass.
 Open Scope type_scope.
 Axiom admit : forall {T}, T.
 Notation "A -> B" := (forall (_ : A), B) : type_scope.
@@ -54,4 +57,4 @@ Goal forall (C D : PreCategory) (G G' : Functor C D)
   (** This [change] succeeded, but did not progress, in 07e4438bd758c2ced8caf09a6961ccd77d84e42b, because [T0 x o T1 x] was not found in the goal *)
   let T0 := match goal with |- context[components_of ?T0 ?x o components_of ?T1 ?x] => constr:(T0) end in
   let T1 := match goal with |- context[components_of ?T0 ?x o components_of ?T1 ?x] => constr:(T1) end in
-  progress change (T0 x o T1 x) with ((fun y => y) (T0 x o T1 x)).
\ No newline at end of file
+  progress change (T0 x o T1 x) with ((fun y => y) (T0 x o T1 x)).
diff --git a/test-suite/bugs/closed/3690.v b/test-suite/bugs/closed/3690.v
index c24173ab..fd9640b8 100644
--- a/test-suite/bugs/closed/3690.v
+++ b/test-suite/bugs/closed/3690.v
@@ -47,7 +47,7 @@ Type@{Top.21} -> Type@{Top.23}
               Top.23 < Top.22
                *) *)
 Fail Check @qux@{Set Set}.
-Fail Check @qux@{Set Set Set}.
+Check @qux@{Type Type Type Type}.
 (* [qux] should only need two universes *)
-Check @qux@{i j k}.  (* Error: The command has not failed!, but I think this is suboptimal *)
+Check @qux@{i j k l}.  (* Error: The command has not failed!, but I think this is suboptimal *)
 Fail Check @qux@{i j}.
diff --git a/test-suite/bugs/closed/3699.v b/test-suite/bugs/closed/3699.v
index aad0bb44..efa43252 100644
--- a/test-suite/bugs/closed/3699.v
+++ b/test-suite/bugs/closed/3699.v
@@ -34,8 +34,7 @@ Module NonPrim.
   : forall b:B, P b.
   Proof.
     intros b.
-    unshelve (refine (pr1 (isconnected_elim _ _))).
-    exact b.
+    unshelve (refine (pr1 (isconnected_elim (A:=hfiber f b) _ _))).
     intro x.
     exact (transport P x.2 (d x.1)).
   Defined.
@@ -47,8 +46,7 @@ Module NonPrim.
   : forall b:B, P b.
   Proof.
     intros b.
-    unshelve (refine (pr1 (isconnected_elim _ _))).
-    exact b.
+    unshelve (refine (pr1 (isconnected_elim (A:=hfiber f b) _ _))).
     intros [a p].
     exact (transport P p (d a)).
   Defined.
@@ -65,7 +63,7 @@ Module NonPrim.
     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
+    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))
@@ -111,8 +109,7 @@ Module Prim.
   : forall b:B, P b.
   Proof.
     intros b.
-    unshelve (refine (pr1 (isconnected_elim _ _))).
-    exact b.
+    unshelve (refine (pr1 (isconnected_elim (A:=hfiber f b) _ _))).
     intro x.
     exact (transport P x.2 (d x.1)).
   Defined.
@@ -124,8 +121,7 @@ Module Prim.
   : forall b:B, P b.
   Proof.
     intros b.
-    unshelve (refine (pr1 (isconnected_elim _ _))).
-    exact b.
+    unshelve (refine (pr1 (isconnected_elim (A:=hfiber f b) _ _))).
     intros [a p].
     exact (transport P p (d a)).
   Defined.
@@ -142,7 +138,7 @@ Module Prim.
     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
+    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))
diff --git a/test-suite/bugs/opened/3753.v b/test-suite/bugs/closed/3753.v
index 05d77c83..5bfbee94 100644
--- a/test-suite/bugs/opened/3753.v
+++ b/test-suite/bugs/closed/3753.v
@@ -1,4 +1,4 @@
 Axiom foo : Type -> Type.
 Axiom bar : forall (T : Type), T -> foo T.
 Arguments bar A x : rename.
-Fail About bar.
+About bar.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3825.v b/test-suite/bugs/closed/3825.v
new file mode 100644
index 00000000..666c6463
--- /dev/null
+++ b/test-suite/bugs/closed/3825.v
@@ -0,0 +1,24 @@
+Set Universe Polymorphism.
+Set Printing Universes.
+
+Axiom foo@{i j} : Type@{i} -> Type@{j}.
+
+Notation bar := foo.
+
+Monomorphic Universes i j.
+
+Check bar@{i j}.
+Fail Check bar@{i}.
+
+Notation qux := (nat -> nat).
+
+Fail Check qux@{i}.
+
+Axiom TruncType@{i} : nat -> Type@{i}.
+
+Notation "n -Type" := (TruncType n) (at level 1) : type_scope.
+Notation hProp := (0)-Type.
+
+Check hProp.
+Check hProp@{i}.
+
diff --git a/test-suite/bugs/opened/3849.v b/test-suite/bugs/closed/3849.v
index 5290054a..a8dc3af9 100644
--- a/test-suite/bugs/opened/3849.v
+++ b/test-suite/bugs/closed/3849.v
@@ -5,4 +5,4 @@ Tactic Notation "bar" hyp_list(hs) := foo hs.
 Goal True.
 do 5 pose proof 0 as ?n0.
 foo n1 n2.
-Fail bar n3 n4.
+bar n3 n4.
diff --git a/test-suite/bugs/closed/3881.v b/test-suite/bugs/closed/3881.v
index 070d1e9c..a327bbf2 100644
--- a/test-suite/bugs/closed/3881.v
+++ b/test-suite/bugs/closed/3881.v
@@ -23,7 +23,7 @@ Proof.
   pose (fun H => @isequiv_homotopic _ _ ((g o f) o f^-1) _ H
                                     (fun b => ap g (eisretr f b))) as k.
   revert k.
-  let x := match goal with |- let k := ?x in _ => constr:x end in
+  let x := match goal with |- let k := ?x in _ => constr:(x) end in
   intro k; clear k;
   pose (x _).
   pose (@isequiv_homotopic _ _ ((g o f) o f^-1) g _
diff --git a/test-suite/bugs/closed/3886.v b/test-suite/bugs/closed/3886.v
new file mode 100644
index 00000000..2ac4abe5
--- /dev/null
+++ b/test-suite/bugs/closed/3886.v
@@ -0,0 +1,23 @@
+Require Import Program.
+
+Inductive Even : nat -> Prop :=
+| evenO : Even O
+| evenS : forall n, Odd n -> Even (S n)
+with Odd : nat -> Prop :=
+| oddS : forall n, Even n -> Odd (S n).
+
+Program Fixpoint doubleE {n} (e : Even n) : Even (2 * n)
+  := _
+with doubleO {n} (o : Odd n) : Odd (S (2 * n))
+     := _.
+Obligations.
+Axiom cheat : forall {A}, A.
+Obligation 1 of doubleE.
+apply cheat.
+Qed.
+
+Obligation 1 of doubleO.
+apply cheat.
+Qed.
+
+Check doubleE.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3911.v b/test-suite/bugs/closed/3911.v
new file mode 100644
index 00000000..b289eafb
--- /dev/null
+++ b/test-suite/bugs/closed/3911.v
@@ -0,0 +1,26 @@
+(* Tested against coq ee596bc *)
+ 
+Set Nonrecursive Elimination Schemes.
+Set Primitive Projections.
+Set Universe Polymorphism.
+ 
+Record setoid := { base : Type }.
+ 
+Definition catdata (Obj Arr : Type) : Type := nat.
+  (* [nat] can be replaced by any other type, it seems,
+     without changing the error *)
+ 
+Record cat : Type :=
+  {
+    obj : setoid;
+    arr : Type;
+    dta : catdata (base obj) arr
+  }.
+ 
+Definition bcwa (C:cat) (B:setoid) :Type := nat.
+  (* As above, nothing special about [nat] here. *)
+ 
+Record temp {C}{B} (e:bcwa C B) :=
+  { fld : base (obj C) }.
+ 
+Print temp_rect.
diff --git a/test-suite/bugs/closed/3920.v b/test-suite/bugs/closed/3920.v
new file mode 100644
index 00000000..a4adb23c
--- /dev/null
+++ b/test-suite/bugs/closed/3920.v
@@ -0,0 +1,7 @@
+Require Import Setoid.
+Axiom P : nat -> Prop.
+Axiom P_or : forall x y, P (x + y) <-> P x \/ P y.
+Lemma foo (H : P 3) : False.
+eapply or_introl in H.
+erewrite <- P_or in H.
+(* Error: No such hypothesis: H *)
diff --git a/test-suite/bugs/closed/3922.v b/test-suite/bugs/closed/3922.v
index 5013bc6a..d88e8c33 100644
--- a/test-suite/bugs/closed/3922.v
+++ b/test-suite/bugs/closed/3922.v
@@ -73,7 +73,7 @@ Definition Trunc_ind {n A}
   (P : Trunc n A -> Type) {Pt : forall aa, IsTrunc n (P aa)}
   : (forall a, P (tr a)) -> (forall aa, P aa)
 := (fun f aa => match aa with tr a => fun _ => f a end Pt).
-Definition merely (A : Type@{i}) : hProp@{i} := BuildhProp (Trunc -1 A).
+Definition merely (A : Type@{i}) : hProp := BuildhProp (Trunc -1 A).
 Definition cconst_factors_contr `{Funext}  {X Y : Type} (f : X -> Y)
            (P : Type) `{Pc : X -> Contr P}
            (g : X -> P) (h : P -> Y) (p : h o g == f)
diff --git a/test-suite/bugs/closed/3929.v b/test-suite/bugs/closed/3929.v
new file mode 100644
index 00000000..955581ef
--- /dev/null
+++ b/test-suite/bugs/closed/3929.v
@@ -0,0 +1,67 @@
+Universes i j.
+Set Printing Universes.
+Set Printing All.
+Polymorphic Definition lt@{x y} : Type@{y} := Type@{x}.
+Goal True.
+evar (T:Type@{i}).
+set (Z := nat : Type@{j}). simpl in Z.
+let Tv:=eval cbv [T] in T in
+pose (x:=Tv).
+revert x.
+refine (_ : let x:=Z in True).
+(** This enforces i <= j *)
+Fail pose (lt@{i j}).
+let Zv:=eval cbv [Z] in Z in
+let Tv:=eval cbv [T] in T in
+constr_eq Zv Tv.
+exact I. 
+Defined.
+
+Goal True.
+evar (T:nat).
+pose (Z:=0).
+let Tv:=eval cbv [T] in T in
+pose (x:=Tv).
+revert x.
+refine (_ : let x:=Z in True).
+let Zv:=eval cbv [Z] in Z in
+let Tv:=eval cbv [T] in T in
+constr_eq Zv Tv.
+Abort.
+
+Goal True.
+evar (T:Set).
+pose (Z:=nat).
+let Tv:=eval cbv [T] in T in
+pose (x:=Tv).
+revert x.
+refine (_ : let x:=Z in True).
+let Zv:=eval cbv [Z] in Z in
+let Tv:=eval cbv [T] in T in
+constr_eq Zv Tv.
+Abort.
+
+Goal forall (A:Type)(a:A), True.
+intros A a.
+evar (T:A).
+pose (Z:=a).
+let Tv:=eval cbv delta [T] in T in
+pose (x:=Tv).
+revert x.
+refine (_ : let x:=Z in True).
+let Zv:=eval cbv [Z] in Z in
+let Tv:=eval cbv [T] in T in
+constr_eq Zv Tv.
+Abort.
+
+Goal True.
+evar (T:Type).
+pose (Z:=nat).
+let Tv:=eval cbv [T] in T in
+pose (x:=Tv).
+revert x.
+refine (_ : let x:=Z in True).
+let Zv:=eval cbv [Z] in Z in
+let Tv:=eval cbv [T] in T in
+constr_eq Zv Tv.
+Abort.
diff --git a/test-suite/bugs/closed/3957.v b/test-suite/bugs/closed/3957.v
new file mode 100644
index 00000000..e20a6e97
--- /dev/null
+++ b/test-suite/bugs/closed/3957.v
@@ -0,0 +1,6 @@
+Ltac foo tac := tac.
+
+Goal True.
+Proof.
+foo subst.
+Admitted.
diff --git a/test-suite/bugs/closed/4069.v b/test-suite/bugs/closed/4069.v
index 21b03ce5..61527764 100644
--- a/test-suite/bugs/closed/4069.v
+++ b/test-suite/bugs/closed/4069.v
@@ -49,3 +49,56 @@ Lemma bar {A} n m (x : A) :
   skipn n (replicate m x) = replicate (m - n) x.
 Proof. intros. f_equal.
 (* 8.5: one goal, n = m - n *)
+Abort.
+
+Variable F : nat -> Set.
+Variable X : forall n, F (n + 1).
+
+Definition sequator{X Y: Set}{eq:X=Y}(x:X) : Y := eq_rec _ _ x _ eq.
+Definition tequator{X Y}{eq:X=Y}(x:X) : Y := eq_rect _ _ x _ eq.
+Polymorphic Definition pequator{X Y}{eq:X=Y}(x:X) : Y := eq_rect _ _ x _ eq.
+
+Goal {n:nat & F (S n)}.
+eexists.
+unshelve eapply (sequator (X _)).
+f_equal. (*behaves*)
+Undo 2.
+unshelve eapply (pequator (X _)).
+f_equal. (*behaves*)
+Undo 2.
+unshelve eapply (tequator (X _)).
+f_equal. (*behaves now *)
+Focus 2. exact 0.
+simpl.
+reflexivity.
+Defined.
+
+(* Part 2: modulo casts introduced by refine due to reductions in goals *)
+
+Goal {n:nat & F (S n)}.
+eexists.
+(*misbehaves, although same goal as above*)
+Set Printing All.
+unshelve refine (sequator (X _)); revgoals.
+2:exact 0. reflexivity.
+Undo 3. 
+unshelve refine (pequator (X _)); revgoals.
+f_equal.
+Undo 2.
+unshelve refine (tequator (X _)); revgoals.
+f_equal.
+Admitted.
+
+Goal @eq Set nat nat.
+congruence.
+Qed.
+
+Goal @eq Type nat nat.
+congruence. 
+Qed.
+
+Variable T : Type.
+
+Goal @eq Type T T.
+congruence.
+Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4095.v b/test-suite/bugs/closed/4095.v
new file mode 100644
index 00000000..ffd33d38
--- /dev/null
+++ b/test-suite/bugs/closed/4095.v
@@ -0,0 +1,87 @@
+(* File reduced by coq-bug-finder from original input, then from 5752 lines to 3828 lines, then from 2707 lines to 558 lines, then from 472 lines to 168 lines, then from 110 lines to 101 lines, then from 96 lines to 77 lines, then from 80 lines to 64 lines, then from 92 lines to 79 lines *)
+(* coqc version 8.5beta1 (February 2015) compiled on Feb 23 2015 18:32:3 with OCaml 4.01.0
+   coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (ebfc19d792492417b129063fb511aa423e9d9e08) *)
+Require Import Coq.Setoids.Setoid.
+Generalizable All Variables.
+Axiom admit : forall {T}, T.
+Ltac admit := apply admit.
+Class Equiv (A : Type) := equiv : relation A.
+Class type (A : Type) {e : Equiv A} := eq_equiv : Equivalence equiv.
+Class ILogicOps Frm := { lentails: relation Frm;
+                         ltrue: Frm;
+                         land: Frm -> Frm -> Frm;
+                         lor: Frm -> Frm -> Frm }.
+Infix "|--"  := lentails (at level 79, no associativity).
+Class ILogic Frm {ILOps: ILogicOps Frm} := { lentailsPre:> PreOrder lentails }.
+Definition lequiv `{ILogic Frm} P Q := P |-- Q /\ Q |-- P.
+Infix "-|-"  := lequiv (at level 85, no associativity).
+Instance lequiv_inverse_lentails `{ILogic Frm} : subrelation lequiv (inverse lentails) := admit.
+Record ILFunFrm (T : Type) `{e : Equiv T} `{ILOps : ILogicOps Frm} := mkILFunFrm { ILFunFrm_pred :> T -> Frm }.
+Section ILogic_Fun.
+  Context (T: Type) `{TType: type T}.
+  Context `{IL: ILogic Frm}.
+  Local Instance ILFun_Ops : ILogicOps (@ILFunFrm T _ Frm _) := admit.
+  Definition ILFun_ILogic : ILogic (@ILFunFrm T _ Frm _) := admit.
+End ILogic_Fun.
+Implicit Arguments ILFunFrm [[ILOps] [e]].
+Instance ILogicOps_Prop : ILogicOps Prop | 2 := {| lentails P Q := (P : Prop) -> Q;
+                                                   ltrue        := True;
+                                                   land     P Q := P /\ Q;
+                                                   lor      P Q := P \/ Q |}.
+Axiom Action : Set.
+Definition Actions := list Action.
+Instance ActionsEquiv : Equiv Actions := { equiv a1 a2 := a1 = a2 }.
+Definition OPred := ILFunFrm Actions Prop.
+Local Existing Instance ILFun_Ops.
+Local Existing Instance ILFun_ILogic.
+Definition catOP (P Q: OPred) : OPred := admit.
+Add Parametric Morphism : catOP with signature lentails ==> lentails ==> lentails as catOP_entails_m.
+admit.
+Defined.
+Definition catOPA (P Q R : OPred) : catOP (catOP P Q) R -|- catOP P (catOP Q R) := admit.
+Class IsPointed (T : Type) := point : T.
+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_catOP `{IsPointed_OPred P, IsPointed_OPred Q} : IsPointed_OPred (catOP P Q) := admit.
+Goal forall (T : Type) (O0 : T -> OPred) (O1 : T -> PointedOPred)
+            (tr : T -> T) (O2 : PointedOPred) (x : T)
+            (H : forall x0 : T, catOP (O0 x0) (O1 (tr x0)) |-- O1 x0),
+     exists e1 e2,
+       catOP (O0 e1) (OPred_pred e2) |-- catOP (O1 x) O2.
+  intros; do 2 esplit.
+  rewrite <- catOPA.
+  lazymatch goal with
+  | |- ?R (?f ?a ?b) (?f ?a' ?b') =>
+    let P := constr:(fun H H' => @Morphisms.proper_prf (OPred -> OPred -> OPred)
+         (@Morphisms.respectful OPred (OPred -> OPred)
+            (@lentails OPred
+               (@ILFun_Ops Actions ActionsEquiv Prop ILogicOps_Prop))
+            (@lentails OPred
+               (@ILFun_Ops Actions ActionsEquiv Prop ILogicOps_Prop) ==>
+             @lentails OPred
+               (@ILFun_Ops Actions ActionsEquiv Prop ILogicOps_Prop))) catOP
+         catOP_entails_m_Proper a a' H b b' H') in
+    pose P;
+    refine (P _ _)
+  end.
+  Undo.
+  Fail lazymatch goal with
+  | |- ?R (?f ?a ?b) (?f ?a' ?b') =>
+    let P := constr:(fun H H' => Morphisms.proper_prf a a' H b b' H') in
+    set(p:=P)
+  end. (* Toplevel input, characters 15-182:
+Error: Cannot infer an instance of type
+"PointedOPred" for the variable p in environment:
+T : Type
+O0 : T -> OPred
+O1 : T -> PointedOPred
+tr : T -> T
+O2 : PointedOPred
+x0 : T
+H : forall x0 : T, catOP (O0 x0) (O1 (tr x0)) |-- O1 x0 *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4187.v b/test-suite/bugs/closed/4187.v
new file mode 100644
index 00000000..b13ca36a
--- /dev/null
+++ b/test-suite/bugs/closed/4187.v
@@ -0,0 +1,709 @@
+(* Lifted from https://coq.inria.fr/bugs/show_bug.cgi?id=4187 *)
+(* File reduced by coq-bug-finder from original input, then from 715 lines to 696 lines *)
+(* coqc version 8.4pl5 (December 2014) compiled on Dec 28 2014 03:23:16 with OCaml 4.01.0
+   coqtop version 8.4pl5 (December 2014) *)
+Set Asymmetric Patterns.
+Axiom proof_admitted : False.
+Tactic Notation "admit" := case proof_admitted.
+Require Import Coq.Lists.List.
+Require Import Coq.Setoids.Setoid.
+Require Import Coq.Numbers.Natural.Peano.NPeano.
+Global Set Implicit Arguments.
+Global Generalizable All Variables.
+Coercion is_true : bool >-> Sortclass.
+Coercion bool_of_sumbool {A B} (x : {A} + {B}) : bool := if x then true else false.
+Fixpoint ForallT {T} (P : T -> Type) (ls : list T) : Type
+  := match ls return Type with
+       | nil => True
+       | x::xs => (P x * ForallT P xs)%type
+     end.
+Fixpoint Forall_tails {T} (P : list T -> Type) (ls : list T) : Type
+  := match ls with
+       | nil => P nil
+       | x::xs => (P (x::xs) * Forall_tails P xs)%type
+     end.
+
+Module Export ADTSynthesis_DOT_Common_DOT_Wf.
+Module Export ADTSynthesis.
+Module Export Common.
+Module Export Wf.
+
+Section wf.
+  Section wf_prod.
+    Context A B (RA : relation A) (RB : relation B).
+Definition prod_relation : relation (A * B).
+exact (fun ab a'b' =>
+           RA (fst ab) (fst a'b') \/ (fst a'b' = fst ab /\ RB (snd ab) (snd a'b'))).
+Defined.
+
+    Fixpoint well_founded_prod_relation_helper
+             a b
+             (wf_A : Acc RA a) (wf_B : well_founded RB) {struct wf_A}
+    : Acc prod_relation (a, b)
+      := match wf_A with
+           | Acc_intro fa => (fix wf_B_rec b' (wf_B' : Acc RB b') : Acc prod_relation (a, b')
+                              := Acc_intro
+                                   _
+                                   (fun ab =>
+                                      match ab as ab return prod_relation ab (a, b') -> Acc prod_relation ab with
+                                        | (a'', b'') =>
+                                          fun pf =>
+                                            match pf with
+                                              | or_introl pf'
+                                                => @well_founded_prod_relation_helper
+                                                     _ _
+                                                     (fa _ pf')
+                                                     wf_B
+                                              | or_intror (conj pfa pfb)
+                                                => match wf_B' with
+                                                     | Acc_intro fb
+                                                       => eq_rect
+                                                            _
+                                                            (fun a'' => Acc prod_relation (a'', b''))
+                                                            (wf_B_rec _ (fb _ pfb))
+                                                            _
+                                                            pfa
+                                                   end
+                                            end
+                                      end)
+                             ) b (wf_B b)
+         end.
+
+    Definition well_founded_prod_relation : well_founded RA -> well_founded RB -> well_founded prod_relation.
+    Proof.
+      intros wf_A wf_B [a b]; hnf in *.
+      apply well_founded_prod_relation_helper; auto.
+    Defined.
+  End wf_prod.
+
+  Section wf_projT1.
+    Context A (B : A -> Type) (R : relation A).
+Definition projT1_relation : relation (sigT B).
+exact (fun ab a'b' =>
+           R (projT1 ab) (projT1 a'b')).
+Defined.
+
+    Definition well_founded_projT1_relation : well_founded R -> well_founded projT1_relation.
+    Proof.
+      intros wf [a b]; hnf in *.
+      induction (wf a) as [a H IH].
+      constructor.
+      intros y r.
+      specialize (IH _ r (projT2 y)).
+      destruct y.
+      exact IH.
+    Defined.
+  End wf_projT1.
+End wf.
+
+Section Fix3.
+  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type)
+          (R : A -> A -> Prop) (Rwf : well_founded R)
+          (P : forall a b c, D a b c -> Type)
+          (F : forall x : A, (forall y : A, R y x -> forall b c d, P y b c d) -> forall b c d, P x b c d).
+Definition Fix3 a b c d : @P a b c d.
+exact (@Fix { a : A & { b : B a & { c : C b & D c } } }
+            (fun x y => R (projT1 x) (projT1 y))
+            (well_founded_projT1_relation Rwf)
+            (fun abcd => P (projT2 (projT2 (projT2 abcd))))
+            (fun x f => @F (projT1 x) (fun y r b c d => f (existT _ y (existT _ b (existT _ c d))) r) _ _ _)
+            (existT _ a (existT _ b (existT _ c d)))).
+Defined.
+End Fix3.
+
+End Wf.
+
+End Common.
+
+End ADTSynthesis.
+
+End ADTSynthesis_DOT_Common_DOT_Wf.
+
+Module Export ADTSynthesis_DOT_Parsers_DOT_StringLike_DOT_Core.
+Module Export ADTSynthesis.
+Module Export Parsers.
+Module Export StringLike.
+Module Export Core.
+Import Coq.Setoids.Setoid.
+Import Coq.Classes.Morphisms.
+
+
+
+Module Export StringLike.
+  Class StringLike {Char : Type} :=
+    {
+      String :> Type;
+      is_char : String -> Char -> bool;
+      length : String -> nat;
+      take : nat -> String -> String;
+      drop : nat -> String -> String;
+      bool_eq : String -> String -> bool;
+      beq : relation String := fun x y => bool_eq x y
+    }.
+
+  Arguments StringLike : clear implicits.
+  Infix "=s" := (@beq _ _) (at level 70, no associativity) : type_scope.
+  Notation "s ~= [ ch ]" := (is_char s ch) (at level 70, no associativity) : string_like_scope.
+  Local Open Scope string_like_scope.
+
+  Definition str_le `{StringLike Char} (s1 s2 : String)
+    := length s1 < length s2 \/ s1 =s s2.
+  Infix "≤s" := str_le (at level 70, right associativity).
+
+  Class StringLikeProperties (Char : Type) `{StringLike Char} :=
+    {
+      singleton_unique : forall s ch ch', s ~= [ ch ] -> s ~= [ ch' ] -> ch = ch';
+      length_singleton : forall s ch, s ~= [ ch ] -> length s = 1;
+      bool_eq_char : forall s s' ch, s ~= [ ch ] -> s' ~= [ ch ] -> s =s s';
+      is_char_Proper :> Proper (beq ==> eq ==> eq) is_char;
+      length_Proper :> Proper (beq ==> eq) length;
+      take_Proper :> Proper (eq ==> beq ==> beq) take;
+      drop_Proper :> Proper (eq ==> beq ==> beq) drop;
+      bool_eq_Equivalence :> Equivalence beq;
+      bool_eq_empty : forall str str', length str = 0 -> length str' = 0 -> str =s str';
+      take_short_length : forall str n, n <= length str -> length (take n str) = n;
+      take_long : forall str n, length str <= n -> take n str =s str;
+      take_take : forall str n m, take n (take m str) =s take (min n m) str;
+      drop_length : forall str n, length (drop n str) = length str - n;
+      drop_0 : forall str, drop 0 str =s str;
+      drop_drop : forall str n m, drop n (drop m str) =s drop (n + m) str;
+      drop_take : forall str n m, drop n (take m str) =s take (m - n) (drop n str);
+      take_drop : forall str n m, take n (drop m str) =s drop m (take (n + m) str)
+    }.
+
+  Arguments StringLikeProperties Char {_}.
+End StringLike.
+
+End Core.
+
+End StringLike.
+
+End Parsers.
+
+End ADTSynthesis.
+
+End ADTSynthesis_DOT_Parsers_DOT_StringLike_DOT_Core.
+
+Module Export ADTSynthesis.
+Module Export Parsers.
+Module Export ContextFreeGrammar.
+Require Import Coq.Strings.String.
+Require Import Coq.Lists.List.
+Export ADTSynthesis.Parsers.StringLike.Core.
+Import ADTSynthesis.Common.
+
+Local Open Scope string_like_scope.
+
+Section cfg.
+  Context {Char : Type}.
+
+  Section definitions.
+
+    Inductive item :=
+    | Terminal (_ : Char)
+    | NonTerminal (_ : string).
+
+    Definition production := list item.
+    Definition productions := list production.
+
+    Record grammar :=
+      {
+        Start_symbol :> string;
+        Lookup :> string -> productions;
+        Start_productions :> productions := Lookup Start_symbol;
+        Valid_nonterminals : list string;
+        Valid_productions : list productions := map Lookup Valid_nonterminals
+      }.
+  End definitions.
+
+  Section parse.
+    Context {HSL : StringLike Char}.
+    Variable G : grammar.
+
+    Inductive parse_of (str : String) : productions -> Type :=
+    | ParseHead : forall pat pats, parse_of_production str pat
+                                   -> parse_of str (pat::pats)
+    | ParseTail : forall pat pats, parse_of str pats
+                                   -> parse_of str (pat::pats)
+    with parse_of_production (str : String) : production -> Type :=
+    | ParseProductionNil : length str = 0 -> parse_of_production str nil
+    | ParseProductionCons : forall n pat pats,
+                              parse_of_item (take n str) pat
+                              -> parse_of_production (drop n str) pats
+                              -> parse_of_production str (pat::pats)
+    with parse_of_item (str : String) : item -> Type :=
+    | ParseTerminal : forall ch, str ~= [ ch ] -> parse_of_item str (Terminal ch)
+    | ParseNonTerminal : forall nt, parse_of str (Lookup G nt)
+                                    -> parse_of_item str (NonTerminal nt).
+  End parse.
+End cfg.
+
+Arguments item _ : clear implicits.
+Arguments production _ : clear implicits.
+Arguments productions _ : clear implicits.
+Arguments grammar _ : clear implicits.
+
+End ContextFreeGrammar.
+
+Module Export BaseTypes.
+
+Section recursive_descent_parser.
+
+  Class parser_computational_predataT :=
+    { nonterminals_listT : Type;
+      initial_nonterminals_data : nonterminals_listT;
+      is_valid_nonterminal : nonterminals_listT -> String.string -> bool;
+      remove_nonterminal : nonterminals_listT -> String.string -> nonterminals_listT;
+      nonterminals_listT_R : nonterminals_listT -> nonterminals_listT -> Prop;
+      remove_nonterminal_dec : forall ls nonterminal,
+                                 is_valid_nonterminal ls nonterminal
+                                 -> nonterminals_listT_R (remove_nonterminal ls nonterminal) ls;
+      ntl_wf : well_founded nonterminals_listT_R }.
+
+  Class parser_removal_dataT' `{predata : parser_computational_predataT} :=
+    { remove_nonterminal_1
+      : forall ls ps ps',
+          is_valid_nonterminal (remove_nonterminal ls ps) ps'
+          -> is_valid_nonterminal ls ps';
+      remove_nonterminal_2
+      : forall ls ps ps',
+          is_valid_nonterminal (remove_nonterminal ls ps) ps' = false
+          <-> is_valid_nonterminal ls ps' = false \/ ps = ps' }.
+End recursive_descent_parser.
+
+End BaseTypes.
+Import Coq.Lists.List.
+Import ADTSynthesis.Parsers.ContextFreeGrammar.
+
+Local Open Scope string_like_scope.
+
+Section cfg.
+  Context {Char} {HSL : StringLike Char} {G : grammar Char}.
+  Context {predata : @parser_computational_predataT}
+          {rdata' : @parser_removal_dataT' predata}.
+
+  Inductive minimal_parse_of
+  : forall (str0 : String) (valid : nonterminals_listT)
+           (str : String),
+      productions Char -> Type :=
+  | MinParseHead : forall str0 valid str pat pats,
+                     @minimal_parse_of_production str0 valid str pat
+                     -> @minimal_parse_of str0 valid str (pat::pats)
+  | MinParseTail : forall str0 valid str pat pats,
+                     @minimal_parse_of str0 valid str pats
+                     -> @minimal_parse_of str0 valid str (pat::pats)
+  with minimal_parse_of_production
+  : forall (str0 : String) (valid : nonterminals_listT)
+           (str : String),
+      production Char -> Type :=
+  | MinParseProductionNil : forall str0 valid str,
+                              length str = 0
+                              -> @minimal_parse_of_production str0 valid str nil
+  | MinParseProductionCons : forall str0 valid str n pat pats,
+                               str ≤s str0
+                               -> @minimal_parse_of_item str0 valid (take n str) pat
+                               -> @minimal_parse_of_production str0 valid (drop n str) pats
+                               -> @minimal_parse_of_production str0 valid str (pat::pats)
+  with minimal_parse_of_item
+  : forall (str0 : String) (valid : nonterminals_listT)
+           (str : String),
+      item Char -> Type :=
+  | MinParseTerminal : forall str0 valid str ch,
+                         str ~= [ ch ]
+                         -> @minimal_parse_of_item str0 valid str (Terminal ch)
+  | MinParseNonTerminal
+    : forall str0 valid str (nt : String.string),
+        @minimal_parse_of_nonterminal str0 valid str nt
+        -> @minimal_parse_of_item str0 valid str (NonTerminal nt)
+  with minimal_parse_of_nonterminal
+  : forall (str0 : String) (valid : nonterminals_listT)
+           (str : String),
+      String.string -> Type :=
+  | MinParseNonTerminalStrLt
+    : forall str0 valid (nt : String.string) str,
+        length str < length str0
+        -> is_valid_nonterminal initial_nonterminals_data nt
+        -> @minimal_parse_of str initial_nonterminals_data str (Lookup G nt)
+        -> @minimal_parse_of_nonterminal str0 valid str nt
+  | MinParseNonTerminalStrEq
+    : forall str0 str valid nonterminal,
+        str =s str0
+        -> is_valid_nonterminal initial_nonterminals_data nonterminal
+        -> is_valid_nonterminal valid nonterminal
+        -> @minimal_parse_of str0 (remove_nonterminal valid nonterminal) str (Lookup G nonterminal)
+        -> @minimal_parse_of_nonterminal str0 valid str nonterminal.
+End cfg.
+Import ADTSynthesis.Common.
+
+Section general.
+  Context {Char} {HSL : StringLike Char} {G : grammar Char}.
+
+  Class boolean_parser_dataT :=
+    { predata :> parser_computational_predataT;
+      split_string_for_production
+      : item Char -> production Char -> String -> list nat }.
+
+  Global Coercion predata : boolean_parser_dataT >-> parser_computational_predataT.
+
+  Definition split_list_completeT `{data : @parser_computational_predataT}
+             {str0 valid}
+             (it : item Char) (its : production Char)
+             (str : String)
+             (pf : str ≤s str0)
+             (split_list : list nat)
+
+    := ({ n : nat
+              & (minimal_parse_of_item (G := G) (predata := data) str0 valid (take n str) it)
+                * (minimal_parse_of_production (G := G) str0 valid (drop n str) its) }%type)
+       -> ({ n : nat
+                 & (In n split_list)
+                   * (minimal_parse_of_item (G := G) str0 valid (take n str) it)
+                   * (minimal_parse_of_production (G := G) str0 valid (drop n str) its) }%type).
+
+  Class boolean_parser_completeness_dataT' `{data : boolean_parser_dataT} :=
+    { split_string_for_production_complete
+      : forall str0 valid str (pf : str ≤s str0) nt,
+          is_valid_nonterminal initial_nonterminals_data nt
+          -> ForallT
+               (Forall_tails
+                  (fun prod
+                   => match prod return Type with
+                        | nil => True
+                        | it::its
+                          => @split_list_completeT data str0 valid it its str pf (split_string_for_production it its str)
+                      end))
+               (Lookup G nt) }.
+End general.
+
+Module Export BooleanRecognizer.
+Import Coq.Numbers.Natural.Peano.NPeano.
+Import Coq.Arith.Compare_dec.
+Import Coq.Arith.Wf_nat.
+
+Section recursive_descent_parser.
+  Context {Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} {G : grammar Char}.
+  Context {data : @boolean_parser_dataT Char _}.
+
+  Section bool.
+    Section parts.
+Definition parse_item
+                 (str_matches_nonterminal : String.string -> bool)
+                 (str : String)
+                 (it : item Char)
+      : bool.
+Admitted.
+
+      Section production.
+        Context {str0}
+                (parse_nonterminal
+                 : forall (str : String),
+                     str ≤s str0
+                     -> String.string
+                     -> bool).
+
+        Fixpoint parse_production
+                 (str : String)
+                 (pf : str ≤s str0)
+                 (prod : production Char)
+        : bool.
+        Proof.
+          refine
+            match prod with
+              | nil =>
+
+                Nat.eq_dec (length str) 0
+              | it::its
+                => let parse_production' := fun str pf => parse_production str pf its in
+                   fold_right
+                     orb
+                     false
+                     (map (fun n =>
+                             (parse_item
+                                (parse_nonterminal (str := take n str) _)
+                                (take n str)
+                                it)
+                               && parse_production' (drop n str) _)%bool
+                          (split_string_for_production it its str))
+            end;
+          revert pf; clear -HSLP; intros; admit.
+        Defined.
+      End production.
+
+      Section productions.
+        Context {str0}
+                (parse_nonterminal
+                 : forall (str : String)
+                          (pf : str ≤s str0),
+                     String.string -> bool).
+Definition parse_productions
+                   (str : String)
+                   (pf : str ≤s str0)
+                   (prods : productions Char)
+        : bool.
+exact (fold_right orb
+                        false
+                        (map (parse_production parse_nonterminal pf)
+                             prods)).
+Defined.
+      End productions.
+
+      Section nonterminals.
+        Section step.
+          Context {str0 valid}
+                  (parse_nonterminal
+                   : forall (p : String * nonterminals_listT),
+                       prod_relation (ltof _ length) nonterminals_listT_R p (str0, valid)
+                       -> forall str : String,
+                            str ≤s fst p -> String.string -> bool).
+
+          Definition parse_nonterminal_step
+                     (str : String)
+                     (pf : str ≤s str0)
+                     (nt : String.string)
+          : bool.
+          Proof.
+            refine
+              (if lt_dec (length str) (length str0)
+               then
+                 parse_productions
+                   (@parse_nonterminal
+                      (str : String, initial_nonterminals_data)
+                      (or_introl _))
+                   (or_intror (reflexivity _))
+                   (Lookup G nt)
+               else
+                 if Sumbool.sumbool_of_bool (is_valid_nonterminal valid nt)
+                 then
+                   parse_productions
+                     (@parse_nonterminal
+                        (str0 : String, remove_nonterminal valid nt)
+                        (or_intror (conj eq_refl (remove_nonterminal_dec _ nt _))))
+                     (str := str)
+                     _
+                     (Lookup G nt)
+                 else
+                   false);
+            assumption.
+          Defined.
+        End step.
+
+        Section wf.
+Definition parse_nonterminal_or_abort
+          : forall (p : String * nonterminals_listT)
+                   (str : String),
+              str ≤s fst p
+              -> String.string
+              -> bool.
+exact (Fix3
+                 _ _ _
+                 (well_founded_prod_relation
+                    (well_founded_ltof _ length)
+                    ntl_wf)
+                 _
+                 (fun sl => @parse_nonterminal_step (fst sl) (snd sl))).
+Defined.
+Definition parse_nonterminal
+                     (str : String)
+                     (nt : String.string)
+          : bool.
+exact (@parse_nonterminal_or_abort
+                 (str : String, initial_nonterminals_data) str
+                 (or_intror (reflexivity _)) nt).
+Defined.
+        End wf.
+      End nonterminals.
+    End parts.
+  End bool.
+End recursive_descent_parser.
+
+Section cfg.
+  Context {Char} {HSL : StringLike Char} {HSLP : @StringLikeProperties Char HSL} (G : grammar Char).
+
+  Section definitions.
+    Context (P : String -> String.string -> Type).
+
+    Definition Forall_parse_of_item'
+               (Forall_parse_of : forall {str pats} (p : parse_of G str pats), Type)
+               {str it} (p : parse_of_item G str it)
+      := match p return Type with
+           | ParseTerminal ch pf => unit
+           | ParseNonTerminal nt p'
+             => (P str nt * Forall_parse_of p')%type
+         end.
+
+    Fixpoint Forall_parse_of {str pats} (p : parse_of G str pats)
+      := match p with
+           | ParseHead pat pats p'
+             => Forall_parse_of_production p'
+           | ParseTail _ _ p'
+             => Forall_parse_of p'
+         end
+    with Forall_parse_of_production {str pat} (p : parse_of_production G str pat)
+         := match p return Type with
+              | ParseProductionNil pf => unit
+              | ParseProductionCons pat strs pats p' p''
+                => (Forall_parse_of_item' (@Forall_parse_of) p' * Forall_parse_of_production p'')%type
+            end.
+
+    Definition Forall_parse_of_item {str it} (p : parse_of_item G str it)
+      := @Forall_parse_of_item' (@Forall_parse_of) str it p.
+  End definitions.
+
+  End cfg.
+
+Section recursive_descent_parser_list.
+  Context {Char} {HSL : StringLike Char} {HLSP : StringLikeProperties Char} {G : grammar Char}.
+Definition rdp_list_nonterminals_listT : Type.
+exact (list String.string).
+Defined.
+Definition rdp_list_is_valid_nonterminal : rdp_list_nonterminals_listT -> String.string -> bool.
+admit.
+Defined.
+Definition rdp_list_remove_nonterminal : rdp_list_nonterminals_listT -> String.string -> rdp_list_nonterminals_listT.
+admit.
+Defined.
+Definition rdp_list_nonterminals_listT_R : rdp_list_nonterminals_listT -> rdp_list_nonterminals_listT -> Prop.
+exact (ltof _ (@List.length _)).
+Defined.
+  Lemma rdp_list_remove_nonterminal_dec : forall ls prods,
+                                            @rdp_list_is_valid_nonterminal ls prods = true
+                                            -> @rdp_list_nonterminals_listT_R (@rdp_list_remove_nonterminal ls prods) ls.
+admit.
+Defined.
+  Lemma rdp_list_ntl_wf : well_founded rdp_list_nonterminals_listT_R.
+  Proof.
+    unfold rdp_list_nonterminals_listT_R.
+    intro.
+    apply well_founded_ltof.
+  Defined.
+
+  Global Instance rdp_list_predata : parser_computational_predataT
+    := { nonterminals_listT := rdp_list_nonterminals_listT;
+         initial_nonterminals_data := Valid_nonterminals G;
+         is_valid_nonterminal := rdp_list_is_valid_nonterminal;
+         remove_nonterminal := rdp_list_remove_nonterminal;
+         nonterminals_listT_R := rdp_list_nonterminals_listT_R;
+         remove_nonterminal_dec := rdp_list_remove_nonterminal_dec;
+         ntl_wf := rdp_list_ntl_wf }.
+End recursive_descent_parser_list.
+
+Section sound.
+  Section general.
+    Context {Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} (G : grammar Char).
+    Context {data : @boolean_parser_dataT Char _}
+            {cdata : @boolean_parser_completeness_dataT' Char _ G data}
+            {rdata : @parser_removal_dataT' predata}.
+
+    Section parts.
+
+      Section nonterminals.
+        Section wf.
+
+          Lemma parse_nonterminal_sound
+                (str : String) (nonterminal : String.string)
+          : parse_nonterminal (G := G) str nonterminal
+            = true
+            -> parse_of_item G str (NonTerminal nonterminal).
+admit.
+Defined.
+        End wf.
+      End nonterminals.
+    End parts.
+  End general.
+End sound.
+
+Import Coq.Strings.String.
+Import ADTSynthesis.Parsers.ContextFreeGrammar.
+
+Fixpoint list_to_productions {T} (default : T) (ls : list (string * T)) : string -> T
+  := match ls with
+       | nil => fun _ => default
+       | (str, t)::ls' => fun s => if string_dec str s
+                                   then t
+                                   else list_to_productions default ls' s
+     end.
+
+Fixpoint list_to_grammar {T} (default : productions T) (ls : list (string * productions T)) : grammar T
+  := {| Start_symbol := hd ""%string (map (@fst _ _) ls);
+        Lookup := list_to_productions default ls;
+        Valid_nonterminals := map (@fst _ _) ls |}.
+
+Section interface.
+  Context {Char} (G : grammar Char).
+Definition production_is_reachable (p : production Char) : Prop.
+admit.
+Defined.
+Definition split_list_is_complete `{HSL : StringLike Char} (str : String) (it : item Char) (its : production Char)
+             (splits : list nat)
+  : Prop.
+exact (forall n,
+         n <= length str
+         -> parse_of_item G (take n str) it
+         -> parse_of_production G (drop n str) its
+         -> production_is_reachable (it::its)
+         -> List.In n splits).
+Defined.
+
+  Record Splitter :=
+    {
+      string_type :> StringLike Char;
+      splits_for : String -> item Char -> production Char -> list nat;
+
+      string_type_properties :> StringLikeProperties Char;
+      splits_for_complete : forall str it its,
+                              split_list_is_complete str it its (splits_for str it its)
+
+    }.
+  Global Existing Instance string_type_properties.
+
+  Record Parser (HSL : StringLike Char) :=
+    {
+      has_parse : @String Char HSL -> bool;
+
+      has_parse_sound : forall str,
+                          has_parse str = true
+                          -> parse_of_item G str (NonTerminal (Start_symbol G));
+
+      has_parse_complete : forall str (p : parse_of_item G str (NonTerminal (Start_symbol G))),
+                             Forall_parse_of_item
+                               (fun _ nt => List.In nt (Valid_nonterminals G))
+                               p
+                             -> has_parse str = true
+    }.
+End interface.
+
+Module Export ParserImplementation.
+
+Section implementation.
+  Context {Char} {G : grammar Char}.
+  Context (splitter : Splitter G).
+
+  Local Instance parser_data : @boolean_parser_dataT Char _ :=
+    { predata := rdp_list_predata (G := G);
+      split_string_for_production it its str
+      := splits_for splitter str it its }.
+
+  Program Definition parser : Parser G splitter
+    := {| has_parse str := parse_nonterminal (G := G) (data := parser_data) str (Start_symbol G);
+          has_parse_sound str Hparse := parse_nonterminal_sound G _ _ Hparse;
+          has_parse_complete str p Hp := _ |}.
+  Next Obligation.
+admit.
+Defined.
+End implementation.
+
+End ParserImplementation.
+
+Section implementation.
+  Context {Char} {ls : list (String.string * productions Char)}.
+  Local Notation G := (list_to_grammar (nil::nil) ls) (only parsing).
+  Context (splitter : Splitter G).
+
+  Local Instance parser_data : @boolean_parser_dataT Char _ := parser_data splitter.
+
+  Goal forall str : @String Char splitter,
+         let G' :=
+             @BooleanRecognizer.parse_nonterminal Char splitter splitter G parser_data str G = true in
+         G'.
+    intros str G'.
+    Timeout 1 assert (pf' : G' -> Prop) by abstract admit.
diff --git a/test-suite/bugs/closed/4198.v b/test-suite/bugs/closed/4198.v
index f85a6026..eb37141b 100644
--- a/test-suite/bugs/closed/4198.v
+++ b/test-suite/bugs/closed/4198.v
@@ -11,7 +11,7 @@ Goal forall A (x x' : A) (xs xs' : list A) (H : x::xs = x'::xs'),
   simpl.
   intros.
   match goal with
-    | [ |- appcontext G[@hd] ] => idtac
+    | [ |- context G[@hd] ] => idtac
   end.
 
 (* This second example comes from CFGV where inspecting subterms of a
diff --git a/test-suite/bugs/opened/4214.v b/test-suite/bugs/closed/4214.v
index 3daf4521..d684e8cf 100644
--- a/test-suite/bugs/opened/4214.v
+++ b/test-suite/bugs/closed/4214.v
@@ -2,4 +2,5 @@
 Goal forall A (a b c : A), b = a -> b = c -> a = c.
 intros.
 subst.
-Fail reflexivity.
+reflexivity.
+Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4292.v b/test-suite/bugs/closed/4292.v
new file mode 100644
index 00000000..403e155e
--- /dev/null
+++ b/test-suite/bugs/closed/4292.v
@@ -0,0 +1,7 @@
+Module Type S. End S.
+
+Declare Module M : S.
+
+Module Type F (T: S). End F.
+
+Fail Module Type N := F with Module T := M.
diff --git a/test-suite/bugs/closed/4375.v b/test-suite/bugs/closed/4375.v
index 03af1653..71e3a751 100644
--- a/test-suite/bugs/closed/4375.v
+++ b/test-suite/bugs/closed/4375.v
@@ -93,14 +93,15 @@ Polymorphic CoInductive foo@{i} (T : Type@{i}) : Type@{i} :=
 | A : foo T -> foo T.
 
 Polymorphic CoFixpoint cg@{i} (t : Type@{i}) : foo@{i} t :=
-  @A@{i} t (cg@{i} t).
+  @A@{i} t (cg t).
 
 Print cg.
 
 Polymorphic CoFixpoint ca@{i} (t : Type@{i}) : foo@{i} t :=
-  @A@{i} t (@cb@{i} t)
+  @A@{i} t (cb t)
 with cb@{i} (t : Type@{i}) : foo@{i} t :=
-  @A@{i} t (@ca@{i} t).
+  @A@{i} t (ca t).
 
 Print ca.
-Print cb.
\ No newline at end of file
+Print cb.
+  
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4378.v b/test-suite/bugs/closed/4378.v
new file mode 100644
index 00000000..9d591655
--- /dev/null
+++ b/test-suite/bugs/closed/4378.v
@@ -0,0 +1,9 @@
+Tactic Notation "epose" open_constr(a) :=
+  let a' := fresh in
+  pose a as a'.
+Tactic Notation "epose2" open_constr(a) tactic3(tac) :=
+  let a' := fresh in
+  pose a as a'.
+Goal True.
+  epose _. Undo.
+  epose2 _ idtac.
diff --git a/test-suite/bugs/closed/4416.v b/test-suite/bugs/closed/4416.v
new file mode 100644
index 00000000..3189685e
--- /dev/null
+++ b/test-suite/bugs/closed/4416.v
@@ -0,0 +1,4 @@
+Goal exists x, x.
+Unset Solve Unification Constraints.
+unshelve refine (ex_intro _ _ _); match goal with _ => refine (_ _) end.
+(* Error: Incorrect number of goals (expected 2 tactics). *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4450.v b/test-suite/bugs/closed/4450.v
new file mode 100644
index 00000000..ecebaba8
--- /dev/null
+++ b/test-suite/bugs/closed/4450.v
@@ -0,0 +1,58 @@
+Polymorphic Axiom inhabited@{u} : Type@{u} -> Prop.
+
+Polymorphic Axiom unit@{u} : Type@{u}.
+Polymorphic Axiom tt@{u} : inhabited unit@{u}.
+
+Polymorphic Hint Resolve tt : the_lemmas.
+Set Printing All.
+Set Printing Universes.
+Goal inhabited unit.
+Proof.
+  eauto with the_lemmas.
+Qed.
+
+Universe u.
+Axiom f : Type@{u} -> Prop.
+Lemma fapp (X : Type) : f X -> False.
+Admitted.
+Polymorphic Axiom funi@{i} : f unit@{i}.
+
+Goal (forall U, f U) -> (*(f unit -> False) ->  *)False /\ False.
+  eauto using (fapp unit funi). (* The two fapp's have different universes *)
+Qed.
+
+Hint Resolve (fapp unit funi) : mylems.
+
+Goal (forall U, f U) -> (*(f unit -> False) ->  *)False /\ False.
+  eauto with mylems. (* Forces the two fapps at the same level *)
+Qed.
+
+Goal (forall U, f U) -> (f unit -> False) -> False /\ False.
+  eauto. (* Forces the two fapps at the same level *)
+Qed.
+
+Polymorphic Definition MyType@{i} := Type@{i}.
+Universes l m n.
+Constraint l < m.
+Polymorphic Axiom maketype@{i} : MyType@{i}.
+
+Goal MyType@{l}.
+Proof.
+  Fail solve [ eauto using maketype@{m} ].
+  eauto using maketype.
+  Undo.
+  eauto using maketype@{n}.
+Qed.
+
+Axiom foo : forall (A : Type), list A.
+Polymorphic Axiom foop@{i} : forall (A : Type@{i}), list A.
+
+Universe x y.
+Goal list Type@{x}.
+Proof.
+  eauto using (foo Type). (* Refreshes the term *)
+  Undo.
+  eauto using foo. Show Universes.
+  Undo.
+  eauto using foop. Show Proof. Show Universes.
+Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4464.v b/test-suite/bugs/closed/4464.v
new file mode 100644
index 00000000..f8e9405d
--- /dev/null
+++ b/test-suite/bugs/closed/4464.v
@@ -0,0 +1,4 @@
+Goal True -> True.
+Proof.
+  intro H'.
+  let H := H' in destruct H; try destruct H.
diff --git a/test-suite/bugs/closed/4471.v b/test-suite/bugs/closed/4471.v
new file mode 100644
index 00000000..36efc42d
--- /dev/null
+++ b/test-suite/bugs/closed/4471.v
@@ -0,0 +1,6 @@
+Goal forall (A B : Type) (P : forall _ : prod A B, Type) (a : A) (b : B) (p p0 : forall (x : A) (x' : B), P (@pair A B x x')),
+    @eq (P (@pair A B a b)) (p (@fst A B (@pair A B a b)) (@snd A B (@pair A B a b)))
+        (p0 (@fst A B (@pair A B a b)) (@snd A B (@pair A B a b))).
+Proof.
+  intros.
+  Fail generalize dependent (a, b).
diff --git a/test-suite/bugs/closed/4479.v b/test-suite/bugs/closed/4479.v
new file mode 100644
index 00000000..921579d1
--- /dev/null
+++ b/test-suite/bugs/closed/4479.v
@@ -0,0 +1,3 @@
+Goal True.
+Fail autorewrite with foo.
+try autorewrite with foo.
diff --git a/test-suite/bugs/closed/4495.v b/test-suite/bugs/closed/4495.v
new file mode 100644
index 00000000..8b032db5
--- /dev/null
+++ b/test-suite/bugs/closed/4495.v
@@ -0,0 +1 @@
+Fail Notation "'forall' x  ..  y ',' P " := (forall x, .. (forall y, P) ..) (at level 200, x binder, y binder).
diff --git a/test-suite/bugs/closed/4498.v b/test-suite/bugs/closed/4498.v
new file mode 100644
index 00000000..ccdb2ddd
--- /dev/null
+++ b/test-suite/bugs/closed/4498.v
@@ -0,0 +1,24 @@
+Require Export Coq.Unicode.Utf8.
+Require Export Coq.Classes.Morphisms.
+Require Export Coq.Relations.Relation_Definitions.
+
+Set Universe Polymorphism.
+
+Reserved Notation "a ~> b" (at level 90, right associativity).
+
+Class Category := {
+  ob            : Type;
+  uhom          := Type : Type;
+  hom           : ob → ob → uhom where "a ~> b" := (hom a b);
+  compose       : ∀ {A B C}, (B ~> C) → (A ~> B) → (A ~> C);
+  equiv         : ∀ {A B}, relation (A ~> B);
+  is_equiv      : ∀ {A B}, @Equivalence (A ~> B) equiv;
+  comp_respects : ∀ {A B C},
+      Proper (@equiv B C ==> @equiv A B ==> @equiv A C) (@compose A B C);
+}.
+
+Require Export Coq.Setoids.Setoid.
+
+Add Parametric Morphism `{C : Category} {A B C} : (@compose _ A B C) with
+  signature equiv ==> equiv ==> equiv as compose_mor.
+Proof. apply comp_respects. Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4503.v b/test-suite/bugs/closed/4503.v
new file mode 100644
index 00000000..f54d6433
--- /dev/null
+++ b/test-suite/bugs/closed/4503.v
@@ -0,0 +1,37 @@
+Require Coq.Classes.RelationClasses.
+
+Class PreOrder (A : Type) (r : A -> A -> Type) : Type :=
+{ refl : forall x, r x x }.
+
+(* FAILURE 1 *)
+
+Section foo.
+  Polymorphic Universes A.
+  Polymorphic Context {A : Type@{A}} {rA : A -> A -> Prop} {PO : PreOrder A rA}.
+
+  Fail Definition foo := PO.
+End foo.
+
+
+Module ILogic.
+
+Set Universe Polymorphism.
+
+(* Logical connectives *)
+Class ILogic@{L} (A : Type@{L}) : Type := mkILogic
+{
+  lentails: A -> A -> Prop;
+  lentailsPre:> RelationClasses.PreOrder lentails
+}.
+
+
+End ILogic.
+
+Set Printing Universes.
+
+(* There is stil a problem if the class is universe polymorphic *)
+Section Embed_ILogic_Pre.
+  Polymorphic Universes A T.
+  Fail Context {A : Type@{A}} {ILA: ILogic.ILogic@{A} A}.
+
+End Embed_ILogic_Pre.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4511.v b/test-suite/bugs/closed/4511.v
new file mode 100644
index 00000000..0cdb3aee
--- /dev/null
+++ b/test-suite/bugs/closed/4511.v
@@ -0,0 +1,3 @@
+Goal True.
+Fail evar I.
+
diff --git a/test-suite/bugs/closed/4519.v b/test-suite/bugs/closed/4519.v
new file mode 100644
index 00000000..ccbc47d2
--- /dev/null
+++ b/test-suite/bugs/closed/4519.v
@@ -0,0 +1,21 @@
+Set Universe Polymorphism.
+Section foo.
+  Universe i.
+  Context (foo : Type@{i}) (bar : Type@{i}).
+  Definition qux@{i} (baz : Type@{i}) := foo -> bar.
+End foo.
+Set Printing Universes.
+Print qux. (* qux@{Top.42 Top.43} =
+fun foo bar _ : Type@{Top.42} => foo -> bar
+     : Type@{Top.42} -> Type@{Top.42} -> Type@{Top.42} -> Type@{Top.42}
+(* Top.42 Top.43 |=  *)
+(* This is wrong; the first two types are equal, but the last one is not *)
+
+qux is universe polymorphic
+Argument scopes are [type_scope type_scope type_scope]
+ *)
+Check qux nat nat nat : Set.
+Check qux nat nat Set : Set. (* Error:
+The term "qux@{Top.50 Top.51} ?T ?T0 Set" has type "Type@{Top.50}" while it is 
+expected to have type "Set"
+(universe inconsistency: Cannot enforce Top.50 = Set because Set < Top.50). *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4527.v b/test-suite/bugs/closed/4527.v
new file mode 100644
index 00000000..08628377
--- /dev/null
+++ b/test-suite/bugs/closed/4527.v
@@ -0,0 +1,267 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-nois" "-indices-matter" "-R" "." "Top" "-top" "bug_bad_univ_length_01") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 1199 lines to 
+430 lines, then from 444 lines to 430 lines, then from 964 lines to 255 lines, 
+then from 269 lines to 255 lines *)
+(* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 
+4.01.0
+   coqtop version 8.5 (January 2016) *)
+Inductive False := .
+Axiom proof_admitted : False.
+Tactic Notation "admit" := case proof_admitted.
+Require Coq.Init.Datatypes.
+
+Import Coq.Init.Notations.
+
+Global Set Universe Polymorphism.
+
+Notation "A -> B" := (forall (_ : A), B) : type_scope.
+
+Inductive True : Type :=
+  I : True.
+Module Export Datatypes.
+
+Set Implicit Arguments.
+Notation nat := Coq.Init.Datatypes.nat.
+Notation S := Coq.Init.Datatypes.S.
+
+Record prod (A B : Type) := pair { fst : A ; snd : B }.
+
+Notation "x * y" := (prod x y) : type_scope.
+
+Open Scope nat_scope.
+
+End Datatypes.
+Module Export Specif.
+
+Set Implicit Arguments.
+
+Record sig {A} (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).
+
+End Specif.
+Definition Type1@{i} := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}.
+
+Definition Type2@{i j} := Eval hnf in let gt := (Type1@{j} : Type@{i}) in 
+Type@{i}.
+
+Definition Type2le@{i j} := Eval hnf in let gt := (Set : Type@{i}) in
+                                        let ge := ((fun x => x) : Type1@{j} -> 
+Type@{i}) in Type@{i}.
+
+Notation idmap := (fun x => x).
+Delimit Scope function_scope with function.
+Delimit Scope path_scope with path.
+Delimit Scope fibration_scope with fibration.
+Open Scope fibration_scope.
+Open Scope function_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.
+
+Notation compose := (fun g f x => g (f x)).
+
+Notation "g 'o' f" := (compose g%function f%function) (at level 40, left 
+associativity) : 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
+  := match p with idpath => idpath end.
+
+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%path q%path) (at level 20) : path_scope.
+
+Notation "p ^" := (inverse p%path) (at level 3, format "p '^'") : 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 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}%type_scope f%function_scope {_} _.
+Arguments eissect {A B}%type_scope f%function_scope {_} _.
+
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : 
+function_scope.
+
+Inductive Unit : Type1 :=
+    tt : Unit.
+
+Local Open Scope path_scope.
+
+Section EquivInverse.
+
+  Context {A B : Type} (f : A -> B) {feq : IsEquiv f}.
+
+  Theorem other_adj (b : B) : eissect f (f^-1 b) = ap f^-1 (eisretr f b).
+admit.
+Defined.
+
+  Global Instance isequiv_inverse : IsEquiv f^-1 | 10000
+    := BuildIsEquiv B A f^-1 f (eissect f) (eisretr f) other_adj.
+End EquivInverse.
+
+Section Adjointify.
+
+  Context {A B : Type} (f : A -> B) (g : B -> A).
+  Context (isretr : Sect g f) (issect : Sect f g).
+
+  Let issect' := fun x =>
+    ap g (ap f (issect x)^)  @  ap g (isretr (f x))  @  issect x.
+
+  Let is_adjoint' (a : A) : isretr (f a) = ap f (issect' a).
+admit.
+Defined.
+
+  Definition isequiv_adjointify : IsEquiv f
+    := BuildIsEquiv A B f g isretr issect' is_adjoint'.
+
+End Adjointify.
+
+  Definition ExtensionAlong {A B : Type} (f : A -> B)
+             (P : B -> Type) (d : forall x:A, P (f x))
+    := { s : forall y:B, P y & forall x:A, s (f x) = d x }.
+
+  Fixpoint ExtendableAlong@{i j k l}
+           (n : nat) {A : Type@{i}} {B : Type@{j}}
+           (f : A -> B) (C : B -> Type@{k}) : Type@{l}
+    := match n with
+         | 0 => Unit@{l}
+         | S n => (forall (g : forall a, C (f a)),
+                     ExtensionAlong@{i j k l l} f C g) *
+                  forall (h k : forall b, C b),
+                    ExtendableAlong n f (fun b => h b = k b)
+       end.
+
+  Definition ooExtendableAlong@{i j k l}
+             {A : Type@{i}} {B : Type@{j}}
+             (f : A -> B) (C : B -> Type@{k}) : Type@{l}
+    := forall n, ExtendableAlong@{i j k l} n f C.
+
+Module Type ReflectiveSubuniverses.
+
+  Parameter ReflectiveSubuniverse@{u a} : Type2@{u a}.
+
+  Parameter O_reflector@{u a i} : forall (O : ReflectiveSubuniverse@{u a}),
+                            Type2le@{i a} -> Type2le@{i a}.
+
+  Parameter In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}),
+                   Type2le@{i a} -> Type2le@{i a}.
+
+  Parameter O_inO@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : 
+Type@{i}),
+                               In@{u a i} O (O_reflector@{u a i} O T).
+
+  Parameter to@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : 
+Type@{i}),
+                   T -> O_reflector@{u a i} O T.
+
+  Parameter inO_equiv_inO@{u a i j k} :
+      forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}) (U : Type@{j})
+             (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f),
+
+        let gei := ((fun x => x) : Type@{i} -> Type@{k}) in
+        let gej := ((fun x => x) : Type@{j} -> Type@{k}) in
+        In@{u a j} O U.
+
+  Parameter extendable_to_O@{u a i j k}
+  : forall (O : ReflectiveSubuniverse@{u a}) {P : Type2le@{i a}} {Q : 
+Type2le@{j a}} {Q_inO : In@{u a j} O Q},
+      ooExtendableAlong@{i i j k} (to O P) (fun _ => Q).
+
+End ReflectiveSubuniverses.
+
+Module ReflectiveSubuniverses_Theory (Os : ReflectiveSubuniverses).
+Export Os.
+
+Existing Class In.
+
+  Coercion O_reflector : ReflectiveSubuniverse >-> Funclass.
+
+Arguments inO_equiv_inO {O} T {U} {_} f {_}.
+Global Existing Instance O_inO.
+
+Section ORecursion.
+  Context {O : ReflectiveSubuniverse}.
+
+  Definition O_indpaths {P Q : Type} {Q_inO : In O Q}
+             (g h : O P -> Q) (p : g o to O P == h o to O P)
+  : g == h
+  := (fst (snd (extendable_to_O O 2) g h) p).1.
+
+  Definition O_indpaths_beta {P Q : Type} {Q_inO : In O Q}
+             (g h : O P -> Q) (p : g o (to O P) == h o (to O P)) (x : P)
+  : O_indpaths g h p (to O P x) = p x
+  := (fst (snd (extendable_to_O O 2) g h) p).2 x.
+
+End ORecursion.
+
+Section Reflective_Subuniverse.
+  Universes Ou Oa.
+  Context (O : ReflectiveSubuniverse@{Ou Oa}).
+
+    Definition inO_isequiv_to_O (T:Type)
+    : IsEquiv (to O T) -> In O T
+    := fun _ => inO_equiv_inO (O T) (to O T)^-1.
+
+    Definition inO_to_O_retract (T:Type) (mu : O T -> T)
+    : Sect (to O T) mu -> In O T.
+    Proof.
+      unfold Sect; intros H.
+      apply inO_isequiv_to_O.
+      apply isequiv_adjointify with (g:=mu).
+      -
+ refine (O_indpaths (to O T o mu) idmap _).
+        intros x; exact (ap (to O T) (H x)).
+      -
+ exact H.
+    Defined.
+
+    Definition inO_paths@{i} (S : Type@{i}) {S_inO : In@{Ou Oa i} O S} (x y : 
+S)    : In@{Ou Oa i} O (x=y).
+    Proof.
+      simple refine (inO_to_O_retract@{i} _ _ _); intro u.
+      -
+ assert (p : (fun _ : O (x=y) => x) == (fun _=> y)).
+        {
+ refine (O_indpaths _ _ _); simpl.
+          intro v; exact v.
+}
+        exact (p u).
+      -
+ hnf.
+        rewrite O_indpaths_beta; reflexivity.
+    Qed.
+    Check inO_paths@{Type}.
diff --git a/test-suite/bugs/closed/4529.v b/test-suite/bugs/closed/4529.v
new file mode 100644
index 00000000..8b3c24fe
--- /dev/null
+++ b/test-suite/bugs/closed/4529.v
@@ -0,0 +1,45 @@
+(* File reduced by coq-bug-finder from original input, then from 1334 lines to 1518 lines, then from 849 lines to 59 lines *)
+(* coqc version 8.5 (January 2016) compiled on Jan 22 2016 18:20:47 with OCaml 4.02.3
+   coqtop version r-schnelltop:/home/r/src/coq/coq,(HEAD detached at V8.5) (5e23fb90b39dfa014ae5c4fb46eb713cca09dbff) *)
+Require Coq.Setoids.Setoid.
+Import Coq.Setoids.Setoid.
+
+Class Equiv A := equiv: relation A.
+Infix "≡" := equiv (at level 70, no associativity).
+Notation "(≡)" := equiv (only parsing).
+
+(* If I remove this line, everything compiles. *)
+Set Primitive Projections.
+
+Class Dist A := dist : nat -> relation A.
+Notation "x ={ n }= y" := (dist n x y)
+  (at level 70, n at next level, format "x  ={ n }=  y").
+
+Record CofeMixin A `{Equiv A, Dist A} := {
+  mixin_equiv_dist x y : x ≡ y <-> forall n, x ={n}= y;
+  mixin_dist_equivalence n : Equivalence (dist n);
+}.
+
+Structure cofeT := CofeT {
+  cofe_car :> Type;
+  cofe_equiv : Equiv cofe_car;
+  cofe_dist : Dist cofe_car;
+  cofe_mixin : CofeMixin cofe_car
+}.
+Existing Instances cofe_equiv cofe_dist.
+Arguments cofe_car : simpl never.
+
+Section cofe_mixin.
+  Context {A : cofeT}.
+  Implicit Types x y : A.
+  Lemma equiv_dist x y : x ≡ y <-> forall n, x ={n}= y.
+Admitted.
+End cofe_mixin.
+  Context {A : cofeT}.
+  Global Instance cofe_equivalence : Equivalence ((≡) : relation A).
+  Proof.
+    split.
+    *
+ intros x.
+apply equiv_dist.
+
diff --git a/test-suite/bugs/closed/4533.v b/test-suite/bugs/closed/4533.v
new file mode 100644
index 00000000..ae17fb14
--- /dev/null
+++ b/test-suite/bugs/closed/4533.v
@@ -0,0 +1,226 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-nois" "-indices-matter" "-R" "." "Top" "-top" "bug_lex_wrong_rewrite_02") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 1125 lines to 
+346 lines, then from 360 lines to 346 lines, then from 822 lines to 271 lines, 
+then from 285 lines to 271 lines *)
+(* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 
+4.01.0
+   coqtop version 8.5 (January 2016) *)
+Inductive False := .
+Axiom proof_admitted : False.
+Tactic Notation "admit" := case proof_admitted.
+Require Coq.Init.Datatypes.
+Import Coq.Init.Notations.
+Global Set Universe Polymorphism.
+Global Set Primitive Projections.
+Notation "A -> B" := (forall (_ : A), B) : type_scope.
+Module Export Datatypes.
+  Set Implicit Arguments.
+  Notation nat := Coq.Init.Datatypes.nat.
+  Notation S := Coq.Init.Datatypes.S.
+  Record prod (A B : Type) := pair { fst : A ; snd : B }.
+  Notation "x * y" := (prod x y) : type_scope.
+  Delimit Scope nat_scope with nat.
+  Open Scope nat_scope.
+End Datatypes.
+Module Export Specif.
+  Set Implicit Arguments.
+  Record sig {A} (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).
+End Specif.
+Global Set Keyed Unification.
+Global Unset Strict Universe Declaration.
+Definition Type1@{i} := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}.
+Definition Type2@{i j} := Eval hnf in let gt := (Type1@{j} : Type@{i}) in 
+Type@{i}.
+Definition Type2le@{i j} := Eval hnf in let gt := (Set : Type@{i}) in
+                                        let ge := ((fun x => x) : Type1@{j} -> 
+Type@{i}) in Type@{i}.
+Notation idmap := (fun x => x).
+Delimit Scope function_scope with function.
+Delimit Scope path_scope with path.
+Delimit Scope fibration_scope with fibration.
+Open Scope fibration_scope.
+Open Scope function_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.
+Notation compose := (fun g f x => g (f x)).
+Notation "g 'o' f" := (compose g%function f%function) (at level 40, left 
+associativity) : 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
+  := match p with idpath => idpath end.
+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%path q%path) (at level 20) : path_scope.
+Notation "p ^" := (inverse p%path) (at level 3, format "p '^'") : 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 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 eissect {A B}%type_scope f%function_scope {_} _.
+Inductive Unit : Type1 := tt : Unit.
+Local Open Scope path_scope.
+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.
+Section Adjointify.
+  Context {A B : Type} (f : A -> B) (g : B -> A).
+  Context (isretr : Sect g f) (issect : Sect f g).
+  Let issect' := fun x =>
+                   ap g (ap f (issect x)^)  @  ap g (isretr (f x))  @  issect x.
+
+  Let is_adjoint' (a : A) : isretr (f a) = ap f (issect' a).
+    admit.
+  Defined.
+
+  Definition isequiv_adjointify : IsEquiv f
+    := BuildIsEquiv A B f g isretr issect' is_adjoint'.
+End Adjointify.
+Definition ExtensionAlong {A B : Type} (f : A -> B)
+           (P : B -> Type) (d : forall x:A, P (f x))
+  := { s : forall y:B, P y & forall x:A, s (f x) = d x }.
+Fixpoint ExtendableAlong@{i j k l}
+         (n : nat) {A : Type@{i}} {B : Type@{j}}
+         (f : A -> B) (C : B -> Type@{k}) : Type@{l}
+  := match n with
+     | 0 => Unit@{l}
+     | S n => (forall (g : forall a, C (f a)),
+                  ExtensionAlong@{i j k l l} f C g) *
+              forall (h k : forall b, C b),
+                ExtendableAlong n f (fun b => h b = k b)
+     end.
+
+Definition ooExtendableAlong@{i j k l}
+           {A : Type@{i}} {B : Type@{j}}
+           (f : A -> B) (C : B -> Type@{k}) : Type@{l}
+  := forall n, ExtendableAlong@{i j k l} n f C.
+
+Module Type ReflectiveSubuniverses.
+
+  Parameter ReflectiveSubuniverse@{u a} : Type2@{u a}.
+
+  Parameter O_reflector@{u a i} : forall (O : ReflectiveSubuniverse@{u a}),
+      Type2le@{i a} -> Type2le@{i a}.
+
+  Parameter In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}),
+      Type2le@{i a} -> Type2le@{i a}.
+
+  Parameter O_inO@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : 
+Type@{i}),
+      In@{u a i} O (O_reflector@{u a i} O T).
+
+  Parameter to@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : 
+Type@{i}),
+      T -> O_reflector@{u a i} O T.
+
+  Parameter extendable_to_O@{u a i j k}
+    : forall (O : ReflectiveSubuniverse@{u a}) {P : Type2le@{i a}} {Q : 
+Type2le@{j a}} {Q_inO : In@{u a j} O Q},
+      ooExtendableAlong@{i i j k} (to O P) (fun _ => Q).
+
+End ReflectiveSubuniverses.
+
+Module ReflectiveSubuniverses_Theory (Os : ReflectiveSubuniverses).
+  Export Os.
+  Existing Class In.
+  Module Export Coercions.
+    Coercion O_reflector : ReflectiveSubuniverse >-> Funclass.
+  End Coercions.
+  Global Existing Instance O_inO.
+
+  Section ORecursion.
+    Context {O : ReflectiveSubuniverse}.
+
+    Definition O_rec {P Q : Type} {Q_inO : In O Q}
+               (f : P -> Q)
+      : O P -> Q
+      := (fst (extendable_to_O O 1%nat) f).1.
+
+    Definition O_rec_beta {P Q : Type} {Q_inO : In O Q}
+               (f : P -> Q) (x : P)
+      : O_rec f (to O P x) = f x
+      := (fst (extendable_to_O O 1%nat) f).2 x.
+
+    Definition O_indpaths {P Q : Type} {Q_inO : In O Q}
+               (g h : O P -> Q) (p : g o to O P == h o to O P)
+      : g == h
+      := (fst (snd (extendable_to_O O 2) g h) p).1.
+
+  End ORecursion.
+
+
+  Section Reflective_Subuniverse.
+    Context (O : ReflectiveSubuniverse@{Ou Oa}).
+
+    Definition isequiv_to_O_inO@{u a i} (T : Type@{i}) `{In@{u a i} O T} : 
+IsEquiv@{i i} (to O T).
+    Proof.
+
+      pose (g := O_rec@{u a i i i i i} idmap).
+      refine (isequiv_adjointify (to O T) g _ _).
+      -
+        refine (O_indpaths@{u a i i i i i} (to O T o g) idmap _).
+        intros x.
+        apply ap.
+        apply O_rec_beta.
+      -
+        intros x.
+        apply O_rec_beta.
+    Defined.
+    Global Existing Instance isequiv_to_O_inO.
+
+  End Reflective_Subuniverse.
+
+End ReflectiveSubuniverses_Theory.
+
+Module Type Preserves_Fibers (Os : ReflectiveSubuniverses).
+  Module Export Os_Theory := ReflectiveSubuniverses_Theory Os.
+End Preserves_Fibers.
+
+Opaque eissect.
+Module Lex_Reflective_Subuniverses
+       (Os : ReflectiveSubuniverses) (Opf : Preserves_Fibers Os).
+  Import Opf.
+  Goal forall (O : ReflectiveSubuniverse) (A : Type) (B : A -> Type) (A_inO : 
+In O A),
+
+      forall g,
+      forall (x : O {x : A & B x}) v v' v'' (p2 : v'' = v') (p0 : v' = v) (p1 : 
+v = _) r,
+        (p2
+           @ (p0
+                @ p1))
+          @ eissect (to O A) (g x) = r.
+    intros.
+    cbv zeta.
+    rewrite concat_p_pp.
+    match goal with
+    | [ |- p2 @ p0 @ p1 @ eissect (to O A) (g x) = r ] => idtac "good"
+    | [ |- ?G ] => fail 1 "bad" G
+    end.
+    Fail rewrite concat_p_pp.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4538.v b/test-suite/bugs/closed/4538.v
new file mode 100644
index 00000000..f925aae9
--- /dev/null
+++ b/test-suite/bugs/closed/4538.v
@@ -0,0 +1 @@
+Reserved Notation "   (u *)   ".
diff --git a/test-suite/bugs/closed/4544.v b/test-suite/bugs/closed/4544.v
new file mode 100644
index 00000000..da140c93
--- /dev/null
+++ b/test-suite/bugs/closed/4544.v
@@ -0,0 +1,1007 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-nois" "-indices-matter" "-R" "." "Top" "-top" "bug_oog_looping_rewrite_01") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 2553 lines to 1932 lines, then from 1946 lines to 1932 lines, then from 2467 lines to 1002 lines, then from 1016 lines to 1002 lines *)
+(* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0
+   coqtop version 8.5 (January 2016) *)
+Inductive False := .
+Axiom proof_admitted : False.
+Tactic Notation "admit" := case proof_admitted.
+Require Coq.Init.Datatypes.
+
+Import Coq.Init.Notations.
+
+Global Set Universe Polymorphism.
+
+Notation "A -> B" := (forall (_ : A), B) : type_scope.
+Global Set Primitive Projections.
+
+Inductive sum (A B : Type) : Type :=
+  | inl : A -> sum A B
+  | inr : B -> sum A B.
+Notation nat := Coq.Init.Datatypes.nat.
+Notation S := Coq.Init.Datatypes.S.
+Notation "x + y" := (sum x y) : type_scope.
+
+Record prod (A B : Type) := pair { fst : A ; snd : B }.
+
+Notation "x * y" := (prod x y) : type_scope.
+Module Export Specif.
+
+Set Implicit Arguments.
+
+Record sig {A} (P : A -> Type) := exist { proj1_sig : A ; proj2_sig : P proj1_sig }.
+Arguments proj1_sig {A P} _ / .
+
+Notation sigT := sig (only parsing).
+Notation existT := exist (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).
+
+End Specif.
+Module Export HoTT_DOT_Basics_DOT_Overture.
+Module Export HoTT.
+Module Export Basics.
+Module Export Overture.
+
+Global Set Keyed Unification.
+
+Global Unset Strict Universe Declaration.
+
+Notation Type0 := Set.
+
+Definition Type1@{i} := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}.
+
+Definition Type2@{i j} := Eval hnf in let gt := (Type1@{j} : Type@{i}) in Type@{i}.
+
+Definition Type2le@{i j} := Eval hnf in let gt := (Set : Type@{i}) in
+                                        let ge := ((fun x => x) : Type1@{j} -> Type@{i}) in Type@{i}.
+
+Notation idmap := (fun x => x).
+Delimit Scope function_scope with function.
+Delimit Scope path_scope with path.
+Delimit Scope fibration_scope with fibration.
+Delimit Scope trunc_scope with trunc.
+
+Open Scope trunc_scope.
+Open Scope path_scope.
+Open Scope fibration_scope.
+Open Scope nat_scope.
+Open Scope function_scope.
+
+Notation "( x ; y )" := (existT _ x y) : 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.
+
+Notation compose := (fun g f x => g (f x)).
+
+Notation "g 'o' f" := (compose g%function f%function) (at level 40, left associativity) : 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
+  := match p with idpath => idpath end.
+
+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%path q%path) (at level 20) : path_scope.
+
+Notation "p ^" := (inverse p%path) (at level 3, format "p '^'") : 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 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}%type_scope f%function_scope {_} _.
+
+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) : type_scope.
+
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : function_scope.
+
+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.
+
+Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope.
+Notation "-2" := minus_two (at level 0) : trunc_scope.
+Notation "-1" := (-2.+1) (at level 0) : trunc_scope.
+Notation "0" := (-1.+1) : 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.
+
+Global Instance istrunc_paths (A : Type) n `{H : IsTrunc n.+1 A} (x y : A)
+: IsTrunc n (x = y)
+  := H x y.
+
+Notation Contr := (IsTrunc -2).
+Notation IsHProp := (IsTrunc -1).
+
+Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances.
+
+Monomorphic Axiom dummy_funext_type : Type0.
+Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }.
+
+Inductive Unit : Type1 :=
+    tt : Unit.
+
+Class IsPointed (A : Type) := point : A.
+
+Arguments point A {_}.
+
+Record pType :=
+  { pointed_type : Type ;
+    ispointed_type : IsPointed pointed_type }.
+
+Coercion pointed_type : pType >-> Sortclass.
+
+Global Existing Instance ispointed_type.
+
+Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }.
+
+Ltac revert_opaque x :=
+  revert x;
+  match goal with
+    | [ |- forall _, _ ] => idtac
+    | _ => fail 1 "Reverted constant is not an opaque variable"
+  end.
+
+End Overture.
+
+End Basics.
+
+End HoTT.
+
+End HoTT_DOT_Basics_DOT_Overture.
+Module Export HoTT_DOT_Basics_DOT_PathGroupoids.
+Module Export HoTT.
+Module Export Basics.
+Module Export PathGroupoids.
+
+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 concat_pV {A : Type} {x y : A} (p : x = y) :
+  p @ p^ = 1
+  :=
+  match p with idpath => 1 end.
+
+Definition moveR_Vp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) :
+  p = r @ q -> r^ @ p = q.
+admit.
+Defined.
+
+Definition moveL_Vp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) :
+  r @ q = p -> q = r^ @ p.
+admit.
+Defined.
+
+Definition moveR_M1 {A : Type} {x y : A} (p q : x = y) :
+  1 = p^ @ q -> p = q.
+admit.
+Defined.
+
+Definition ap_pp {A B : Type} (f : A -> B) {x y z : A} (p : x = y) (q : y = z) :
+  ap f (p @ q) = (ap f p) @ (ap f q)
+  :=
+  match q with
+    idpath =>
+    match p with idpath => 1 end
+  end.
+
+Definition ap_V {A B : Type} (f : A -> B) {x y : A} (p : x = y) :
+  ap f (p^) = (ap f p)^
+  :=
+  match p with idpath => 1 end.
+
+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_pA1 {A : Type} {f : A -> A} (p : forall x, x = f x) {x y : A} (q : x = y) :
+  (p x) @ (ap f q) =  q @ (p y)
+  :=
+  match q as i in (_ = y) return (p x @ ap f i = i @ p y) with
+    | idpath => concat_p1 _ @ (concat_1p _)^
+  end.
+
+End PathGroupoids.
+
+End Basics.
+
+End HoTT.
+
+End HoTT_DOT_Basics_DOT_PathGroupoids.
+Module Export HoTT_DOT_Basics_DOT_Equivalences.
+Module Export HoTT.
+Module Export Basics.
+Module Export Equivalences.
+
+Definition isequiv_commsq {A B C D}
+           (f : A -> B) (g : C -> D) (h : A -> C) (k : B -> D)
+           (p : k o f == g o h)
+           `{IsEquiv _ _ f} `{IsEquiv _ _ h} `{IsEquiv _ _ k}
+: IsEquiv g.
+admit.
+Defined.
+
+Section Adjointify.
+
+  Context {A B : Type} (f : A -> B) (g : B -> A).
+  Context (isretr : Sect g f) (issect : Sect f g).
+
+  Let issect' := fun x =>
+    ap g (ap f (issect x)^)  @  ap g (isretr (f x))  @  issect x.
+
+  Let is_adjoint' (a : A) : isretr (f a) = ap f (issect' a).
+  Proof.
+    unfold issect'.
+    apply moveR_M1.
+    repeat rewrite ap_pp, concat_p_pp; rewrite <- ap_compose.
+    rewrite (concat_pA1 (fun b => (isretr b)^) (ap f (issect a)^)).
+    repeat rewrite concat_pp_p; rewrite ap_V; apply moveL_Vp; rewrite concat_p1.
+    rewrite concat_p_pp, <- ap_compose.
+    rewrite (concat_pA1 (fun b => (isretr b)^) (isretr (f a))).
+    rewrite concat_pV, concat_1p; reflexivity.
+  Qed.
+
+  Definition isequiv_adjointify : IsEquiv f
+    := BuildIsEquiv A B f g isretr issect' is_adjoint'.
+
+End Adjointify.
+
+End Equivalences.
+
+End Basics.
+
+End HoTT.
+
+End HoTT_DOT_Basics_DOT_Equivalences.
+Module Export HoTT_DOT_Basics_DOT_Trunc.
+Module Export HoTT.
+Module Export Basics.
+Module Export Trunc.
+Generalizable Variables A B m n f.
+
+Definition trunc_equiv A {B} (f : A -> B)
+  `{IsTrunc n A} `{IsEquiv A B f}
+  : IsTrunc n B.
+admit.
+Defined.
+
+Record TruncType (n : trunc_index) := BuildTruncType {
+  trunctype_type : Type ;
+  istrunc_trunctype_type : IsTrunc n trunctype_type
+}.
+
+Arguments BuildTruncType _ _ {_}.
+
+Coercion trunctype_type : TruncType >-> Sortclass.
+
+Notation "n -Type" := (TruncType n) (at level 1) : type_scope.
+Notation hProp := (-1)-Type.
+
+Notation BuildhProp := (BuildTruncType -1).
+
+End Trunc.
+
+End Basics.
+
+End HoTT.
+
+End HoTT_DOT_Basics_DOT_Trunc.
+Module Export HoTT_DOT_Types_DOT_Unit.
+Module Export HoTT.
+Module Export Types.
+Module Export Unit.
+
+Notation unit_name x := (fun (_ : Unit) => x).
+
+End Unit.
+
+End Types.
+
+End HoTT.
+
+End HoTT_DOT_Types_DOT_Unit.
+Module Export HoTT_DOT_Types_DOT_Sigma.
+Module Export HoTT.
+Module Export Types.
+Module Export Sigma.
+Local Open Scope path_scope.
+
+Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P)
+           (pq : {p : u.1 = v.1 & p # u.2 = v.2})
+: u = v
+  := match pq.2 in (_ = v2) return u = (v.1; v2) with
+       | 1 => match pq.1 as p in (_ = v1) return u = (v1; p # u.2) with
+                | 1 => 1
+              end
+     end.
+
+Definition path_sigma {A : Type} (P : A -> Type) (u v : sigT P)
+           (p : u.1 = v.1) (q : p # u.2 = v.2)
+: u = v
+  := path_sigma_uncurried P u v (p;q).
+
+Definition path_sigma' {A : Type} (P : A -> Type) {x x' : A} {y : P x} {y' : P x'}
+           (p : x = x') (q : p # y = y')
+: (x;y) = (x';y')
+  := path_sigma P (x;y) (x';y') p q.
+
+Global Instance isequiv_pr1_contr {A} {P : A -> Type}
+         `{forall a, Contr (P a)}
+: IsEquiv (@pr1 A P) | 100.
+Proof.
+  refine (isequiv_adjointify (@pr1 A P)
+                             (fun a => (a ; center (P a))) _ _).
+  -
+ intros a; reflexivity.
+  -
+ intros [a p].
+    refine (path_sigma' P 1 (contr _)).
+Defined.
+
+Definition path_sigma_hprop {A : Type} {P : A -> Type}
+           `{forall x, IsHProp (P x)}
+           (u v : sigT P)
+: u.1 = v.1 -> u = v
+  := path_sigma_uncurried P u v o pr1^-1.
+
+End Sigma.
+
+End Types.
+
+End HoTT.
+
+End HoTT_DOT_Types_DOT_Sigma.
+Module Export HoTT_DOT_Extensions.
+Module Export HoTT.
+Module Export Extensions.
+
+Section Extensions.
+
+  Definition ExtensionAlong {A B : Type} (f : A -> B)
+             (P : B -> Type) (d : forall x:A, P (f x))
+    := { s : forall y:B, P y & forall x:A, s (f x) = d x }.
+
+  Fixpoint ExtendableAlong@{i j k l}
+           (n : nat) {A : Type@{i}} {B : Type@{j}}
+           (f : A -> B) (C : B -> Type@{k}) : Type@{l}
+    := match n with
+         | 0 => Unit@{l}
+         | S n => (forall (g : forall a, C (f a)),
+                     ExtensionAlong@{i j k l l} f C g) *
+                  forall (h k : forall b, C b),
+                    ExtendableAlong n f (fun b => h b = k b)
+       end.
+
+  Definition ooExtendableAlong@{i j k l}
+             {A : Type@{i}} {B : Type@{j}}
+             (f : A -> B) (C : B -> Type@{k}) : Type@{l}
+    := forall n, ExtendableAlong@{i j k l} n f C.
+
+End Extensions.
+
+End Extensions.
+
+End HoTT.
+
+End HoTT_DOT_Extensions.
+Module Export HoTT.
+Module Export Modalities.
+Module Export ReflectiveSubuniverse.
+
+Module Type ReflectiveSubuniverses.
+
+  Parameter ReflectiveSubuniverse@{u a} : Type2@{u a}.
+
+  Parameter O_reflector@{u a i} : forall (O : ReflectiveSubuniverse@{u a}),
+                            Type2le@{i a} -> Type2le@{i a}.
+
+  Parameter In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}),
+                   Type2le@{i a} -> Type2le@{i a}.
+
+  Parameter O_inO@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}),
+                               In@{u a i} O (O_reflector@{u a i} O T).
+
+  Parameter to@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}),
+                   T -> O_reflector@{u a i} O T.
+
+  Parameter inO_equiv_inO@{u a i j k} :
+      forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}) (U : Type@{j})
+             (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f),
+
+        let gei := ((fun x => x) : Type@{i} -> Type@{k}) in
+        let gej := ((fun x => x) : Type@{j} -> Type@{k}) in
+        In@{u a j} O U.
+
+  Parameter hprop_inO@{u a i}
+  : Funext -> forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}),
+                IsHProp (In@{u a i} O T).
+
+  Parameter extendable_to_O@{u a i j k}
+  : forall (O : ReflectiveSubuniverse@{u a}) {P : Type2le@{i a}} {Q : Type2le@{j a}} {Q_inO : In@{u a j} O Q},
+      ooExtendableAlong@{i i j k} (to O P) (fun _ => Q).
+
+End ReflectiveSubuniverses.
+
+Module ReflectiveSubuniverses_Theory (Os : ReflectiveSubuniverses).
+Export Os.
+
+Module Export Coercions.
+
+  Coercion O_reflector : ReflectiveSubuniverse >-> Funclass.
+
+End Coercions.
+
+End ReflectiveSubuniverses_Theory.
+
+Module Type ReflectiveSubuniverses_Restriction_Data (Os : ReflectiveSubuniverses).
+
+  Parameter New_ReflectiveSubuniverse@{u a} : Type2@{u a}.
+
+  Parameter ReflectiveSubuniverses_restriction@{u a}
+  : New_ReflectiveSubuniverse@{u a} -> Os.ReflectiveSubuniverse@{u a}.
+
+End ReflectiveSubuniverses_Restriction_Data.
+
+Module ReflectiveSubuniverses_Restriction
+       (Os : ReflectiveSubuniverses)
+       (Res : ReflectiveSubuniverses_Restriction_Data Os)
+<: ReflectiveSubuniverses.
+
+  Definition ReflectiveSubuniverse := Res.New_ReflectiveSubuniverse.
+
+  Definition O_reflector@{u a i} (O : ReflectiveSubuniverse@{u a})
+    := Os.O_reflector@{u a i} (Res.ReflectiveSubuniverses_restriction O).
+  Definition In@{u a i} (O : ReflectiveSubuniverse@{u a})
+    := Os.In@{u a i} (Res.ReflectiveSubuniverses_restriction O).
+  Definition O_inO@{u a i} (O : ReflectiveSubuniverse@{u a})
+    := Os.O_inO@{u a i} (Res.ReflectiveSubuniverses_restriction O).
+  Definition to@{u a i} (O : ReflectiveSubuniverse@{u a})
+    := Os.to@{u a i} (Res.ReflectiveSubuniverses_restriction O).
+  Definition inO_equiv_inO@{u a i j k} (O : ReflectiveSubuniverse@{u a})
+    := Os.inO_equiv_inO@{u a i j k} (Res.ReflectiveSubuniverses_restriction O).
+  Definition hprop_inO@{u a i} (H : Funext) (O : ReflectiveSubuniverse@{u a})
+    := Os.hprop_inO@{u a i} H (Res.ReflectiveSubuniverses_restriction O).
+  Definition extendable_to_O@{u a i j k} (O : ReflectiveSubuniverse@{u a})
+    := @Os.extendable_to_O@{u a i j k} (Res.ReflectiveSubuniverses_restriction@{u a} O).
+
+End ReflectiveSubuniverses_Restriction.
+
+Module ReflectiveSubuniverses_FamUnion
+       (Os1 Os2 : ReflectiveSubuniverses)
+<: ReflectiveSubuniverses.
+
+  Definition ReflectiveSubuniverse@{u a} : Type2@{u a}
+    := Os1.ReflectiveSubuniverse@{u a} + Os2.ReflectiveSubuniverse@{u a}.
+
+  Definition O_reflector@{u a i} : forall (O : ReflectiveSubuniverse@{u a}),
+                             Type2le@{i a} -> Type2le@{i a}.
+admit.
+Defined.
+
+  Definition In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}),
+                             Type2le@{i a} -> Type2le@{i a}.
+  Proof.
+    intros [O|O]; [ exact (Os1.In@{u a i} O)
+                  | exact (Os2.In@{u a i} O) ].
+  Defined.
+
+  Definition O_inO@{u a i}
+  : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}),
+      In@{u a i} O (O_reflector@{u a i} O T).
+admit.
+Defined.
+
+  Definition to@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}),
+                   T -> O_reflector@{u a i} O T.
+admit.
+Defined.
+
+  Definition inO_equiv_inO@{u a i j k} :
+      forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}) (U : Type@{j})
+             (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f),
+        In@{u a j} O U.
+  Proof.
+    intros [O|O]; [ exact (Os1.inO_equiv_inO@{u a i j k} O)
+                  | exact (Os2.inO_equiv_inO@{u a i j k} O) ].
+  Defined.
+
+  Definition hprop_inO@{u a i}
+  : Funext -> forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}),
+                IsHProp (In@{u a i} O T).
+admit.
+Defined.
+
+  Definition extendable_to_O@{u a i j k}
+  : forall (O : ReflectiveSubuniverse@{u a}) {P : Type2le@{i a}} {Q : Type2le@{j a}} {Q_inO : In@{u a j} O Q},
+      ooExtendableAlong@{i i j k} (to O P) (fun _ => Q).
+admit.
+Defined.
+
+End ReflectiveSubuniverses_FamUnion.
+
+End ReflectiveSubuniverse.
+
+End Modalities.
+
+End HoTT.
+
+Module Type Modalities.
+
+  Parameter Modality@{u a} : Type2@{u a}.
+
+  Parameter O_reflector@{u a i} : forall (O : Modality@{u a}),
+                            Type2le@{i a} -> Type2le@{i a}.
+
+  Parameter In@{u a i} : forall (O : Modality@{u a}),
+                            Type2le@{i a} -> Type2le@{i a}.
+
+  Parameter O_inO@{u a i} : forall (O : Modality@{u a}) (T : Type@{i}),
+                               In@{u a i} O (O_reflector@{u a i} O T).
+
+  Parameter to@{u a i} : forall (O : Modality@{u a}) (T : Type@{i}),
+                   T -> O_reflector@{u a i} O T.
+
+  Parameter inO_equiv_inO@{u a i j k} :
+      forall (O : Modality@{u a}) (T : Type@{i}) (U : Type@{j})
+             (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f),
+
+        let gei := ((fun x => x) : Type@{i} -> Type@{k}) in
+        let gej := ((fun x => x) : Type@{j} -> Type@{k}) in
+        In@{u a j} O U.
+
+  Parameter hprop_inO@{u a i}
+  : Funext -> forall (O : Modality@{u a}) (T : Type@{i}),
+                IsHProp (In@{u a i} O T).
+
+End Modalities.
+
+Module Modalities_to_ReflectiveSubuniverses
+       (Os : Modalities) <: ReflectiveSubuniverses.
+
+  Import Os.
+
+  Fixpoint O_extendable@{u a i j k} (O : Modality@{u a})
+           (A : Type@{i}) (B : O_reflector O A -> Type@{j})
+           (B_inO : forall a, In@{u a j} O (B a)) (n : nat)
+  : ExtendableAlong@{i i j k} n (to O A) B.
+admit.
+Defined.
+
+  Definition ReflectiveSubuniverse := Modality.
+
+  Definition O_reflector@{u a i} := O_reflector@{u a i}.
+
+  Definition In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}),
+                   Type2le@{i a} -> Type2le@{i a}
+    := In@{u a i}.
+  Definition O_inO@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}),
+                               In@{u a i} O (O_reflector@{u a i} O T)
+    := O_inO@{u a i}.
+  Definition to@{u a i} := to@{u a i}.
+  Definition inO_equiv_inO@{u a i j k} :
+      forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}) (U : Type@{j})
+             (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f),
+        In@{u a j} O U
+    := inO_equiv_inO@{u a i j k}.
+  Definition hprop_inO@{u a i}
+  : Funext -> forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}),
+                IsHProp (In@{u a i} O T)
+    := hprop_inO@{u a i}.
+
+  Definition extendable_to_O@{u a i j k} (O : ReflectiveSubuniverse@{u a})
+             {P : Type2le@{i a}} {Q : Type2le@{j a}} {Q_inO : In@{u a j} O Q}
+  : ooExtendableAlong@{i i j k} (to O P) (fun _ => Q)
+    := fun n => O_extendable O P (fun _ => Q) (fun _ => Q_inO) n.
+
+End Modalities_to_ReflectiveSubuniverses.
+
+Module Type EasyModalities.
+
+  Parameter Modality@{u a} : Type2@{u a}.
+
+  Parameter O_reflector@{u a i} : forall (O : Modality@{u a}),
+                            Type2le@{i a} -> Type2le@{i a}.
+
+  Parameter to@{u a i} : forall (O : Modality@{u a}) (T : Type@{i}),
+                   T -> O_reflector@{u a i} O T.
+
+  Parameter minO_pathsO@{u a i}
+  : forall (O : Modality@{u a}) (A : Type@{i})
+           (z z' : O_reflector@{u a i} O A),
+      IsEquiv (to@{u a i} O (z = z')).
+
+End EasyModalities.
+
+Module EasyModalities_to_Modalities (Os : EasyModalities)
+<: Modalities.
+
+  Import Os.
+
+  Definition Modality := Modality.
+
+  Definition O_reflector@{u a i} := O_reflector@{u a i}.
+  Definition to@{u a i} := to@{u a i}.
+
+  Definition In@{u a i}
+  : forall (O : Modality@{u a}), Type@{i} -> Type@{i}
+  := fun O A => IsEquiv@{i i} (to O A).
+
+  Definition hprop_inO@{u a i} `{Funext} (O : Modality@{u a})
+             (T : Type@{i})
+  : IsHProp (In@{u a i} O T).
+admit.
+Defined.
+
+  Definition O_ind_internal@{u a i j k} (O : Modality@{u a})
+             (A : Type@{i}) (B : O_reflector@{u a i} O A -> Type@{j})
+             (B_inO : forall oa, In@{u a j} O (B oa))
+  : let gei := ((fun x => x) : Type@{i} -> Type@{k}) in
+    let gej := ((fun x => x) : Type@{j} -> Type@{k}) in
+    (forall a, B (to O A a)) -> forall oa, B oa.
+admit.
+Defined.
+
+  Definition O_ind_beta_internal@{u a i j k} (O : Modality@{u a})
+             (A : Type@{i}) (B : O_reflector@{u a i} O A -> Type@{j})
+             (B_inO : forall oa, In@{u a j} O (B oa))
+             (f : forall a : A, B (to O A a)) (a:A)
+  : O_ind_internal@{u a i j k} O A B B_inO f (to O A a) = f a.
+admit.
+Defined.
+
+  Definition O_inO@{u a i} (O : Modality@{u a}) (A : Type@{i})
+  : In@{u a i} O (O_reflector@{u a i} O A).
+admit.
+Defined.
+
+  Definition inO_equiv_inO@{u a i j k} (O : Modality@{u a}) (A : Type@{i}) (B : Type@{j})
+    (A_inO : In@{u a i} O A) (f : A -> B) (feq : IsEquiv f)
+  : In@{u a j} O B.
+  Proof.
+    simple refine (isequiv_commsq (to O A) (to O B) f
+             (O_ind_internal O A (fun _ => O_reflector O B) _ (fun a => to O B (f a))) _).
+    -
+ intros; apply O_inO.
+    -
+ intros a; refine (O_ind_beta_internal@{u a i j k} O A (fun _ => O_reflector O B) _ _ a).
+    -
+ apply A_inO.
+    -
+ simple refine (isequiv_adjointify _
+               (O_ind_internal O B (fun _ => O_reflector O A) _ (fun b => to O A (f^-1 b))) _ _);
+        intros x.
+      +
+ apply O_inO.
+      +
+ pattern x; refine (O_ind_internal O B _ _ _ x); intros.
+        *
+ apply minO_pathsO.
+        *
+ simpl; admit.
+      +
+ pattern x; refine (O_ind_internal O A _ _ _ x); intros.
+        *
+ apply minO_pathsO.
+        *
+ simpl; admit.
+  Defined.
+
+End EasyModalities_to_Modalities.
+
+Module Modalities_Theory (Os : Modalities).
+
+Export Os.
+Module Export Os_ReflectiveSubuniverses
+  := Modalities_to_ReflectiveSubuniverses Os.
+Module Export RSU
+  := ReflectiveSubuniverses_Theory Os_ReflectiveSubuniverses.
+
+Module Export Coercions.
+  Coercion modality_to_reflective_subuniverse
+    := idmap : Modality -> ReflectiveSubuniverse.
+End Coercions.
+
+Class IsConnected (O : Modality@{u a}) (A : Type@{i})
+
+  := isconnected_contr_O : IsTrunc@{i} -2 (O A).
+
+Class IsConnMap (O : Modality@{u a})
+      {A : Type@{i}} {B : Type@{j}} (f : A -> B)
+  := isconnected_hfiber_conn_map
+
+     : forall b:B, IsConnected@{u a k} O (hfiber@{i j} f b).
+
+End Modalities_Theory.
+
+Private Inductive Trunc (n : trunc_index) (A :Type) : Type :=
+  tr : A -> Trunc n A.
+Arguments tr {n A} a.
+
+Global Instance istrunc_truncation (n : trunc_index) (A : Type@{i})
+: IsTrunc@{j} n (Trunc@{i} n A).
+Admitted.
+
+Definition Trunc_ind {n A}
+  (P : Trunc n A -> Type) {Pt : forall aa, IsTrunc n (P aa)}
+  : (forall a, P (tr a)) -> (forall aa, P aa)
+:= (fun f aa => match aa with tr a => fun _ => f a end Pt).
+
+Definition Truncation_Modality := trunc_index.
+
+Module Truncation_Modalities <: Modalities.
+
+  Definition Modality : Type2@{u a} := Truncation_Modality.
+
+  Definition O_reflector (n : Modality@{u u'}) A := Trunc n A.
+
+  Definition In (n : Modality@{u u'}) A := IsTrunc n A.
+
+  Definition O_inO (n : Modality@{u u'}) A : In n (O_reflector n A).
+admit.
+Defined.
+
+  Definition to (n : Modality@{u u'}) A := @tr n A.
+
+  Definition inO_equiv_inO (n : Modality@{u u'})
+             (A : Type@{i}) (B : Type@{j}) Atr f feq
+  : let gei := ((fun x => x) : Type@{i} -> Type@{k}) in
+    let gej := ((fun x => x) : Type@{j} -> Type@{k}) in
+    In n B
+  := @trunc_equiv A B f n Atr feq.
+
+  Definition hprop_inO `{Funext} (n : Modality@{u u'}) A
+  : IsHProp (In n A).
+admit.
+Defined.
+
+End Truncation_Modalities.
+
+Module Import TrM := Modalities_Theory Truncation_Modalities.
+
+Definition merely (A : Type@{i}) : hProp := BuildhProp (Trunc -1 A).
+
+Notation IsSurjection := (IsConnMap -1).
+
+Definition BuildIsSurjection {A B} (f : A -> B) :
+  (forall b, merely (hfiber f b)) -> IsSurjection f.
+admit.
+Defined.
+
+Ltac strip_truncations :=
+
+  progress repeat match goal with
+                    | [ T : _ |- _ ]
+                      => revert_opaque T;
+                        refine (@Trunc_ind _ _ _ _ _);
+
+                        [];
+                        intro T
+                  end.
+Local Open Scope trunc_scope.
+
+Global Instance conn_pointed_type {n : trunc_index} {A : Type} (a0:A)
+ `{IsConnMap n _ _ (unit_name a0)} : IsConnected n.+1 A | 1000.
+admit.
+Defined.
+
+Definition loops (A : pType) : pType :=
+  Build_pType (point A = point A) idpath.
+
+Record pMap (A B : pType) :=
+  { pointed_fun : A -> B ;
+    point_eq : pointed_fun (point A) = point B }.
+
+Arguments point_eq {A B} f : rename.
+Coercion pointed_fun : pMap >-> Funclass.
+
+Infix "->*" := pMap (at level 99) : pointed_scope.
+Local Open Scope pointed_scope.
+
+Definition pmap_compose {A B C : pType}
+           (g : B ->* C) (f : A ->* B)
+: A ->* C
+  := Build_pMap A C (g o f)
+                (ap g (point_eq f) @ point_eq g).
+
+Record pHomotopy {A B : pType} (f g : pMap A B) :=
+  { pointed_htpy : f == g ;
+    point_htpy : pointed_htpy (point A) @ point_eq g = point_eq f }.
+Arguments pointed_htpy {A B f g} p x.
+
+Infix "==*" := pHomotopy (at level 70, no associativity) : pointed_scope.
+
+Definition loops_functor {A B : pType} (f : A ->* B)
+: (loops A) ->* (loops B).
+Proof.
+  refine (Build_pMap (loops A) (loops B)
+            (fun p => (point_eq f)^ @ (ap f p @ point_eq f)) _).
+  apply moveR_Vp; simpl.
+  refine (concat_1p _ @ (concat_p1 _)^).
+Defined.
+
+Definition loops_functor_compose {A B C : pType}
+           (g : B ->* C) (f : A ->* B)
+: (loops_functor (pmap_compose g f))
+   ==* (pmap_compose (loops_functor g) (loops_functor f)).
+admit.
+Defined.
+
+Local Open Scope path_scope.
+
+Record ooGroup :=
+  { classifying_space : pType@{i} ;
+    isconn_classifying_space : IsConnected@{u a i} 0 classifying_space
+  }.
+
+Local Notation B := classifying_space.
+
+Definition group_type (G : ooGroup) : Type
+  := point (B G) = point (B G).
+
+Coercion group_type : ooGroup >-> Sortclass.
+
+Definition group_loops (X : pType)
+: ooGroup.
+Proof.
+
+  pose (x0 := point X);
+  pose (BG := (Build_pType
+               { x:X & merely (x = point X) }
+               (existT (fun x:X => merely (x = point X)) x0 (tr 1)))).
+
+  cut (IsConnected 0 BG).
+  {
+ exact (Build_ooGroup BG).
+}
+  cut (IsSurjection (unit_name (point BG))).
+  {
+ intros; refine (conn_pointed_type (point _)).
+}
+  apply BuildIsSurjection; simpl; intros [x p].
+  strip_truncations; apply tr; exists tt.
+  apply path_sigma_hprop; simpl.
+  exact (p^).
+Defined.
+
+Definition loops_group (X : pType)
+: loops X <~> group_loops X.
+admit.
+Defined.
+
+Definition ooGroupHom (G H : ooGroup)
+  := pMap (B G) (B H).
+
+Definition grouphom_fun {G H} (phi : ooGroupHom G H) : G -> H
+  := loops_functor phi.
+
+Coercion grouphom_fun : ooGroupHom >-> Funclass.
+
+Definition group_loops_functor
+           {X Y : pType} (f : pMap X Y)
+: ooGroupHom (group_loops X) (group_loops Y).
+Proof.
+  simple refine (Build_pMap _ _ _ _); simpl.
+  -
+ intros [x p].
+    exists (f x).
+    strip_truncations; apply tr.
+    exact (ap f p @ point_eq f).
+  -
+ apply path_sigma_hprop; simpl.
+    apply point_eq.
+Defined.
+
+Definition loops_functor_group
+           {X Y : pType} (f : pMap X Y)
+: loops_functor (group_loops_functor f) o loops_group X
+  == loops_group Y o loops_functor f.
+admit.
+Defined.
+
+Definition grouphom_compose {G H K : ooGroup}
+           (psi : ooGroupHom H K) (phi : ooGroupHom G H)
+: ooGroupHom G K
+  := pmap_compose psi phi.
+
+Definition group_loops_functor_compose
+           {X Y Z : pType}
+           (psi : pMap Y Z) (phi : pMap X Y)
+: grouphom_compose (group_loops_functor psi) (group_loops_functor phi)
+  == group_loops_functor (pmap_compose psi phi).
+Proof.
+  intros g.
+  unfold grouphom_fun, grouphom_compose.
+  refine (pointed_htpy (loops_functor_compose _ _) g @ _).
+  pose (p := eisretr (loops_group X) g).
+  change (loops_functor (group_loops_functor psi)
+            (loops_functor (group_loops_functor phi) g)
+          = loops_functor (group_loops_functor
+                                 (pmap_compose psi phi)) g).
+  rewrite <- p.
+  Fail Timeout 1 Time rewrite !loops_functor_group.
+  (* 0.004 s in 8.5rc1, 8.677 s in 8.5 *)
+  Timeout 1 do 3 rewrite loops_functor_group.
+Abort.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4574.v b/test-suite/bugs/closed/4574.v
new file mode 100644
index 00000000..39ba1903
--- /dev/null
+++ b/test-suite/bugs/closed/4574.v
@@ -0,0 +1,8 @@
+Require Import Setoid.
+
+Definition block A (a : A) := a.
+
+Goal forall A (a : A), block Type nat.
+Proof.
+Fail reflexivity.
+
diff --git a/test-suite/bugs/closed/4576.v b/test-suite/bugs/closed/4576.v
new file mode 100644
index 00000000..2c643ea7
--- /dev/null
+++ b/test-suite/bugs/closed/4576.v
@@ -0,0 +1,3 @@
+Definition foo := O.
+Arguments foo : simpl nomatch.
+Timeout 1 Eval cbn in id foo.
diff --git a/test-suite/bugs/closed/4580.v b/test-suite/bugs/closed/4580.v
new file mode 100644
index 00000000..4ffd5f0f
--- /dev/null
+++ b/test-suite/bugs/closed/4580.v
@@ -0,0 +1,6 @@
+Require Import Program.
+
+Class Foo (A : Type) := foo : A.
+
+Unset Refine Instance Mode.
+Program Instance f1 : Foo nat := S _.
diff --git a/test-suite/bugs/closed/4582.v b/test-suite/bugs/closed/4582.v
new file mode 100644
index 00000000..0842fb8f
--- /dev/null
+++ b/test-suite/bugs/closed/4582.v
@@ -0,0 +1,10 @@
+Require List.
+Import List.ListNotations.
+
+Variable Foo : nat -> nat.
+
+Delimit Scope Foo_scope with F.
+
+Notation " [ x ] " := (Foo x) : Foo_scope.
+
+Check ([1] : nat)%F.
diff --git a/test-suite/bugs/closed/4588.v b/test-suite/bugs/closed/4588.v
new file mode 100644
index 00000000..ff66277e
--- /dev/null
+++ b/test-suite/bugs/closed/4588.v
@@ -0,0 +1,10 @@
+Set Primitive Projections.
+
+(* This proof was accepted in Coq 8.5 because the subterm specs were not
+projected correctly *)
+Inductive foo : Prop := mkfoo { proj1 : False -> foo; proj2 : (forall P : Prop, P -> P) }.
+
+Fail Fixpoint loop (x : foo) : False :=
+  loop (proj2 x _ x).
+
+Fail Definition bad : False := loop (mkfoo (fun x => match x with end) (fun _ x => x)).
diff --git a/test-suite/bugs/closed/4596.v b/test-suite/bugs/closed/4596.v
new file mode 100644
index 00000000..592fdb65
--- /dev/null
+++ b/test-suite/bugs/closed/4596.v
@@ -0,0 +1,14 @@
+Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms.
+
+Definition T (x : bool) := x = true.
+
+Goal forall (S : Type) (b b0 : S -> nat -> bool) (str : S) (p : nat)
+  (s : forall n : nat, bool)
+  (s0 s1 : nat -> S -> S),
+  (forall (str0 : S) (n m : nat),
+  (if s m then T (b0 (s1 n str0) 0) else T (b (s1 n str0) 0)) -> T (b (s0 n str0) m) ->
+    T (b str0 m)) ->
+  T (b str p).
+Proof.
+intros ???????? H0.
+rewrite H0.
diff --git a/test-suite/bugs/closed/4603.v b/test-suite/bugs/closed/4603.v
new file mode 100644
index 00000000..e7567623
--- /dev/null
+++ b/test-suite/bugs/closed/4603.v
@@ -0,0 +1,10 @@
+Axiom A : Type.
+
+Goal True. exact I.
+Check (fun P => P A).
+Abort.
+
+Goal True.
+Definition foo (A : Type) : Prop:= True. 
+  set (x:=foo). split.
+Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4616.v b/test-suite/bugs/closed/4616.v
new file mode 100644
index 00000000..c862f820
--- /dev/null
+++ b/test-suite/bugs/closed/4616.v
@@ -0,0 +1,4 @@
+Set Primitive Projections.
+Record Foo' := Foo { foo : Type }.
+Axiom f : forall t : Foo', foo t.
+Extraction f.
diff --git a/test-suite/bugs/closed/4622.v b/test-suite/bugs/closed/4622.v
new file mode 100644
index 00000000..ffa478cb
--- /dev/null
+++ b/test-suite/bugs/closed/4622.v
@@ -0,0 +1,24 @@
+Set Primitive Projections.
+
+Record foo : Type := bar { x : unit }.
+
+Goal forall t u, bar t = bar u -> t = u.
+Proof.
+  intros.
+  injection H.
+  trivial.
+Qed.
+(* Was: Error: Pattern-matching expression on an object of inductive type foo has invalid information. *)
+
+(** Dependent pattern-matching is ok on this one as it has eta *)
+Definition baz (x : foo) :=
+  match x as x' return x' = x' with
+  | bar u => eq_refl
+  end.
+
+Inductive foo' : Type := bar' {x' : unit; y: foo'}.
+(** Dependent pattern-matching is not ok on this one *)
+Fail Definition baz' (x : foo') :=
+  match x as x' return x' = x' with
+  | bar' u y => eq_refl
+  end.
diff --git a/test-suite/bugs/closed/4627.v b/test-suite/bugs/closed/4627.v
new file mode 100644
index 00000000..e1206bb3
--- /dev/null
+++ b/test-suite/bugs/closed/4627.v
@@ -0,0 +1,49 @@
+Class sa (A:Type) := { }.
+
+Record predicate A (sa:sa A) :=
+  { pred_fun: A->Prop }.
+Record ABC : Type :=
+  { abc: Type }.
+Record T :=
+  { T_abc: ABC }.
+
+
+(*
+sa: forall _ : Type@{Top.179}, Prop
+predicate: forall (A : Type@{Top.205}) (_ : sa A), Type@{max(Set+1, Top.205)}
+T: Type@{Top.208+1}
+ABC: Type@{Top.208+1}
+abc: forall _ : ABC, Type@{Top.208}
+
+Top.205 <= Top.179   predicate <= sa.A
+Set < Top.208        Set < abc
+Set < Top.205        Set < predicate
+*)
+
+Definition foo : predicate T (Build_sa T) :=
+    {| pred_fun:= fun w => True |}.
+(* *)
+(* Top.208 < Top.205   <--- added by foo *)
+(* *)
+
+Check predicate nat (Build_sa nat).
+(*
+
+The issue is that the template polymorphic universe of [predicate], Top.205, does not get replaced with the universe of [nat] in the above line.
+  -Jason Gross
+
+8.5          -- predicate nat (Build_sa nat): Type@{max(Set+1, Top.205)}
+8.5 EXPECTED -- predicate nat (Build_sa nat): Type@{Set+1}
+8.4pl4       -- predicate nat {| |}: Type (* max(Set, (Set)+1) *)
+*)
+
+(* This works in 8.4pl4 and SHOULD work in 8.5 *)
+Definition bar : ABC :=
+  {| abc:= predicate nat (Build_sa nat) |}.
+(*
+The term "predicate nat (Build_sa nat)" has type
+ "Type@{max(Set+1, Top.205)}"
+while it is expected to have type "Type@{Top.208}"
+(universe inconsistency: Cannot enforce Top.205 <=
+Top.208 because Top.208 < Top.205).
+*)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4628.v b/test-suite/bugs/closed/4628.v
new file mode 100644
index 00000000..7d4a15d6
--- /dev/null
+++ b/test-suite/bugs/closed/4628.v
@@ -0,0 +1,46 @@
+Module first.
+  Polymorphic Record BAR (A:Type) :=
+  { foo: A->Prop; bar: forall (x y: A), foo x -> foo y}.
+
+Section A.
+Context {A:Type}.
+
+Set Printing Universes.
+
+Hint Resolve bar.
+Goal forall (P:BAR A) x y, foo _ P x -> foo _ P y.
+intros.
+eauto.
+Qed.
+End A.
+End first.
+
+Module firstbest.
+  Polymorphic Record BAR (A:Type) :=
+  { foo: A->Prop; bar: forall (x y: A), foo x -> foo y}.
+
+Section A.
+Context {A:Type}.
+
+Set Printing Universes.
+
+Polymorphic Hint Resolve bar.
+Goal forall (P:BAR A) x y, foo _ P x -> foo _ P y.
+intros.
+eauto.
+Qed.
+End A.
+End firstbest.
+
+Module second.
+Axiom foo: Set.
+Axiom foo': Set.
+
+Polymorphic Record BAR (A:Type) :=
+  { bar: foo' -> foo}.
+Set Printing Universes.
+
+Lemma baz@{i}: forall (P:BAR@{Set} nat), foo' -> foo.
+  eauto using bar.
+Qed.
+End second.
diff --git a/test-suite/bugs/closed/4634.v b/test-suite/bugs/closed/4634.v
new file mode 100644
index 00000000..77e31e10
--- /dev/null
+++ b/test-suite/bugs/closed/4634.v
@@ -0,0 +1,16 @@
+Set Primitive Projections.
+
+Polymorphic Record pair {A B : Type} : Type :=
+  prod { pr1 : A; pr2 : B }.
+
+Notation " ( x ; y ) " := (@prod _ _ x y).
+Notation " x .1 " := (pr1 x) (at level 3).
+Notation " x .2 " := (pr2 x) (at level 3).
+
+Goal ((0; 1); 2).1.2 = 1.
+Proof.
+  cbv.
+  match goal with
+  | |- ?t = ?t => exact (eq_refl t)
+  end.
+Qed.
diff --git a/test-suite/bugs/closed/4644.v b/test-suite/bugs/closed/4644.v
new file mode 100644
index 00000000..f09b27c2
--- /dev/null
+++ b/test-suite/bugs/closed/4644.v
@@ -0,0 +1,52 @@
+(* Testing a regression of unification in 8.5 in problems of the form
+   "match ?y with ... end = ?x args" *)
+
+Lemma foo : exists b, forall a, match a with tt => tt end = b a.
+Proof.
+eexists. intro.
+refine (_ : _ = match _ with tt => _ end).
+refine eq_refl.
+Qed.
+
+(**********************************************************************)
+
+Axiom proof_admitted : False.
+Tactic Notation "admit" := case proof_admitted.
+Require Export Coq.Classes.Morphisms.
+Require Import Coq.Lists.List.
+
+Global Set Implicit Arguments.
+
+Definition list_caset A (P : list A -> Type) (N : P nil) (C : forall x xs, P (x::xs))
+           ls
+  : P ls
+  := match ls with
+     | nil => N
+     | x::xs => C x xs
+     end.
+
+Axiom list_caset_Proper'
+  : forall {A P},
+    Proper (eq
+              ==> pointwise_relation _ (pointwise_relation _ eq)
+              ==> eq
+              ==> eq)
+           (@list_caset A (fun _ => P)).
+Goal forall (T T' : Set) (a3 : list T), exists y2, forall (a4 : T' -> bool),
+        match a3 with
+        | nil => 0
+        | (_ :: _)%list => 1
+        end = y2 a4.
+  clear; eexists; intros.
+  reflexivity. Undo.
+  Local Ltac t :=
+    lazymatch goal with
+    | [ |- match ?v with nil => ?N | cons x xs => @?C x xs end = _ :> ?P ]
+      => let T := type of v in
+         let A := match (eval hnf in T) with list ?A => A end in
+         refine (@list_caset_Proper' A P _ _ _ _ _ _ _ _ _
+                 : @list_caset A (fun _ => P) N C v = match _ with nil => _ | cons x xs => _ end)
+    end.
+  (etransitivity; [ t | reflexivity ]) || fail 0 "too early".
+  Undo.
+  t.
diff --git a/test-suite/bugs/closed/4653.v b/test-suite/bugs/closed/4653.v
new file mode 100644
index 00000000..4514342c
--- /dev/null
+++ b/test-suite/bugs/closed/4653.v
@@ -0,0 +1,3 @@
+Definition T := Type.
+Module Type S. Parameter foo : let A := T in True. End S.
+Module M <: S. Lemma foo (A := T) : True. Proof I. End M.
diff --git a/test-suite/bugs/closed/4656.v b/test-suite/bugs/closed/4656.v
new file mode 100644
index 00000000..c89a86d6
--- /dev/null
+++ b/test-suite/bugs/closed/4656.v
@@ -0,0 +1,4 @@
+(* -*- coq-prog-args: ("-emacs" "-compat" "8.4") -*- *)
+Goal True.
+  constructor 1.
+Qed.
diff --git a/test-suite/bugs/closed/4661.v b/test-suite/bugs/closed/4661.v
new file mode 100644
index 00000000..03d2350a
--- /dev/null
+++ b/test-suite/bugs/closed/4661.v
@@ -0,0 +1,10 @@
+Module Type Test.
+  Parameter t : Type.
+End Test.
+
+Module Type Func (T:Test).
+  Parameter x : Type.
+End Func.
+
+Module Shortest_path (T : Test).
+Print Func.
diff --git a/test-suite/bugs/closed/4663.v b/test-suite/bugs/closed/4663.v
new file mode 100644
index 00000000..b7661988
--- /dev/null
+++ b/test-suite/bugs/closed/4663.v
@@ -0,0 +1,3 @@
+Coercion foo (n : nat) : Set.
+Admitted.
+Check (0 : Set).
diff --git a/test-suite/bugs/closed/4670.v b/test-suite/bugs/closed/4670.v
new file mode 100644
index 00000000..61139929
--- /dev/null
+++ b/test-suite/bugs/closed/4670.v
@@ -0,0 +1,7 @@
+Require Import Coq.Vectors.Vector.
+Module Bar.
+  Definition foo A n (l : Vector.t A n) : True.
+  Proof.
+    induction l ; exact I.
+  Defined.
+End Bar.
diff --git a/test-suite/bugs/closed/4673.v b/test-suite/bugs/closed/4673.v
new file mode 100644
index 00000000..1ae50818
--- /dev/null
+++ b/test-suite/bugs/closed/4673.v
@@ -0,0 +1,57 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-R" "." "Fiat" "-top" "BooleanRecognizerOptimized" "-R" "." "Top") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 2407 lines to 22 lines, then from 528 lines to 35 lines, then from 331 lines to 42 lines, then from 56 lines to 42 lines, then from 63 lines to 46 lines, then from 60 lines to 46 lines *) (* coqc version 8.5 (February 2016) compiled on Feb 21 2016 15:26:16 with OCaml 4.02.3
+   coqtop version 8.5 (February 2016) *)
+Axiom proof_admitted : False.
+Tactic Notation "admit" := case proof_admitted.
+Require Coq.Lists.List.
+Import Coq.Lists.List.
+Import Coq.Classes.Morphisms.
+
+Definition list_caset A (P : list A -> Type) (N : P nil) (C : forall x xs, P (x::xs))
+           ls
+  : P ls
+  := match ls with
+     | nil => N
+     | x::xs => C x xs
+     end.
+
+Global Instance list_caset_Proper' {A P}
+  : Proper (eq
+              ==> pointwise_relation _ (pointwise_relation _ eq)
+              ==> eq
+              ==> eq)
+           (@list_caset A (fun _ => P)).
+admit.
+Defined.
+
+Global Instance list_caset_Proper'' {A P}
+  : (Proper (eq ==> pointwise_relation _ (pointwise_relation _ eq) ==> forall_relation (fun _ => eq))
+   (list_caset A (fun _ => P))).
+Admitted.
+
+Goal    forall (Char : Type) (P : forall _ : list bool, Prop) (l : list bool) (l0 : forall _ : forall _ : Char, bool, list bool)
+               
+               (T : Type) (T0 : forall _ : T, Type) (t : T),
+    
+    let predata := t in
+
+    forall (splitdata : T0 predata) (l5 : forall _ : T0 t, list nat) (T1 : Type) (b : forall (_ : T1) (_ : Char), bool)
+           
+           (T2 : Type) (a11 : T2) (xs : list T2) (T3 : Type) (i0 : T3) (P0 : Set) (b1 : forall (_ : nat) (_ : P0), bool)
+           
+           (l2 : forall (_ : forall _ : T1, list bool) (_ : forall _ : P0, list bool) (_ : T2), list bool)
+           
+           (l1 : forall (_ : forall _ : forall _ : Char, bool, list bool) (_ : forall _ : P0, list bool) (_ : T3), list bool)
+           
+           (_ : forall NT : forall _ : P0, list bool, @eq (list bool) (l1 l0 NT i0) (l2 (fun f : T1 => l0 (b f)) NT a11)),
+      
+      P
+        (@list_caset T2 (fun _ : list T2 => list bool) l
+                     (fun (_ : T2) (_ : list T2) => l1 l0 (fun a9 : P0 => @map nat bool (fun x0 : nat => b1 x0 a9) (l5 splitdata)) i0
+) xs).
+  intros.
+  subst predata;
+  let H := match goal with H : forall _, _ = _ |- _ => H end in
+  setoid_rewrite H || fail 0 "too early".
+  Undo.
+  setoid_rewrite H.
diff --git a/test-suite/bugs/closed/4679.v b/test-suite/bugs/closed/4679.v
new file mode 100644
index 00000000..c94fa31a
--- /dev/null
+++ b/test-suite/bugs/closed/4679.v
@@ -0,0 +1,18 @@
+Require Import Coq.Setoids.Setoid.
+Goal forall (T : nat -> Set -> Set) (U : Set)
+            (H : forall n : nat, T n (match n with
+                                      | 0 => fun x => x
+                                      | S _ => fun x => x
+                                      end (nat = nat)) = U),
+    T 0 (nat = nat) = U.
+Proof.
+  intros.
+  let H := match goal with H : forall _, eq _ _ |- _ => H end in
+  rewrite H || fail 0 "too early".
+  Undo.
+  let H := match goal with H : forall _, eq _ _ |- _ => H end in
+  setoid_rewrite (H 0) || fail 0 "too early".
+  Undo.
+  setoid_rewrite H. (* Error: Tactic failure: setoid rewrite failed: Nothing to rewrite. *)
+  reflexivity.
+Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4684.v b/test-suite/bugs/closed/4684.v
new file mode 100644
index 00000000..9c0bed42
--- /dev/null
+++ b/test-suite/bugs/closed/4684.v
@@ -0,0 +1,32 @@
+(*Suppose a user wants to declare a new list-like notation with support for singletons in both 8.4 and 8.5.  If they use*)
+Require Import Coq.Lists.List.
+Require Import Coq.Vectors.Vector.
+Import ListNotations.
+Import VectorNotations.
+Set Implicit Arguments.
+Inductive mylist T := mynil | mycons (_ : T) (_ : mylist T).
+Arguments mynil {_}, _.
+
+Delimit Scope mylist_scope with mylist.
+Bind Scope mylist_scope with mylist.
+Delimit Scope vector_scope with vector.
+
+Notation " [ ] " := mynil (format "[ ]") : mylist_scope.
+Notation " [ x ] " := (mycons x mynil) : mylist_scope.
+Notation " [ x ; y ; .. ; z ] " := (mycons x (mycons y .. (mycons z mynil) ..)) : mylist_scope.
+
+Check [ ]%mylist : mylist _.
+Check [ ]%list : list _.
+Check []%vector : Vector.t _ _.
+Check [ _ ]%mylist : mylist _.
+Check [ _ ]%list : list _.
+Check [ _ ]%vector : Vector.t _ _.
+Check [ _ ; _ ]%list : list _.
+Check [ _ ; _ ]%vector : Vector.t _ _.
+Check [ _ ; _ ]%mylist : mylist _.
+Check [ _ ; _ ; _ ]%list : list _.
+Check [ _ ; _ ; _ ]%vector : Vector.t _ _.
+Check [ _ ; _ ; _ ]%mylist : mylist _.
+Check [ _ ; _ ; _ ; _ ]%list : list _.
+Check [ _ ; _ ; _ ; _ ]%vector : Vector.t _ _.
+Check [ _ ; _ ; _ ; _ ]%mylist : mylist _.
diff --git a/test-suite/bugs/closed/4695.v b/test-suite/bugs/closed/4695.v
new file mode 100644
index 00000000..a4227181
--- /dev/null
+++ b/test-suite/bugs/closed/4695.v
@@ -0,0 +1,38 @@
+(* 
+The Qed at the end of this file was slow in 8.5 and 8.5pl1 because the kernel
+term comparison after evaluation was done on constants according to their user
+names. The conversion still succeeded because delta applied, but was much
+slower than with a canonical names comparison.
+*)
+
+Module Mod0.
+
+  Fixpoint rec_ t d : nat :=
+    match d with
+    | O => O
+    | S d' =>
+      match t with
+      | true => rec_ t d'
+      | false => rec_ t d'
+      end
+    end.
+
+  Definition depth := 1000.
+
+  Definition rec t := rec_ t depth.
+
+End Mod0.
+
+
+Module Mod1.
+  Module M := Mod0.
+End Mod1.
+
+
+Axiom rec_prop : forall t d n, Mod1.M.rec_ t d = n.
+
+Lemma slow_qed : forall t n,
+    Mod0.rec t = n.
+Proof.
+  intros; unfold Mod0.rec; apply rec_prop.
+Timeout 2 Qed.
diff --git a/test-suite/bugs/closed/4708.v b/test-suite/bugs/closed/4708.v
new file mode 100644
index 00000000..ad2e5810
--- /dev/null
+++ b/test-suite/bugs/closed/4708.v
@@ -0,0 +1,8 @@
+(*Doc, it hurts when I poke myself.*)
+
+Notation "'" := 1. (* was:
+Setting notation at level 0.
+Toplevel input, characters 0-18:
+> Notation "'" := 1.
+> ^^^^^^^^^^^^^^^^^^
+Anomaly: Uncaught exception Invalid_argument("index out of bounds"). Please report. *)
diff --git a/test-suite/bugs/closed/4710.v b/test-suite/bugs/closed/4710.v
new file mode 100644
index 00000000..fdc85010
--- /dev/null
+++ b/test-suite/bugs/closed/4710.v
@@ -0,0 +1,12 @@
+Set Primitive Projections.
+Record Foo' := Foo { foo : nat }.
+Extraction foo.
+Record Foo2 (a : nat) := Foo2c { foo2p : nat; foo2b : bool }.
+Extraction Language Ocaml.
+Extraction foo2p.
+
+Definition bla (x : Foo2 0) := foo2p _ x.
+Extraction bla.
+
+Definition bla' (a : nat) (x : Foo2 a) := foo2b _ x.
+Extraction bla'.
diff --git a/test-suite/bugs/closed/4713.v b/test-suite/bugs/closed/4713.v
new file mode 100644
index 00000000..5d4d73be
--- /dev/null
+++ b/test-suite/bugs/closed/4713.v
@@ -0,0 +1,10 @@
+Module Type T.
+  Parameter t : Type.
+End T.
+Module M : T.
+  Definition t := unit.
+End M.
+
+Fail Module Z : T with Module t := M := M.
+Fail Module Z <: T with Module t := M := M.
+Fail Declare Module Z : T with Module t := M.
diff --git a/test-suite/bugs/closed/4718.v b/test-suite/bugs/closed/4718.v
new file mode 100644
index 00000000..12a4e8fc
--- /dev/null
+++ b/test-suite/bugs/closed/4718.v
@@ -0,0 +1,15 @@
+(*Congruence is weaker than reflexivity when it comes to higher level than necessary equalities:*)
+
+Goal @eq Set nat nat.
+congruence.
+Qed.
+
+Goal @eq Type nat nat.
+congruence. (*bug*)
+Qed.
+
+Variable T : Type.
+
+Goal @eq Type T T.
+congruence.
+Qed.
diff --git a/test-suite/bugs/closed/4722.v b/test-suite/bugs/closed/4722.v
new file mode 100644
index 00000000..f047624c
--- /dev/null
+++ b/test-suite/bugs/closed/4722.v
@@ -0,0 +1 @@
+(* -*- coq-prog-args: ("-emacs" "-R" "4722" "Foo") -*- *)
diff --git a/test-suite/bugs/closed/4722/tata b/test-suite/bugs/closed/4722/tata
new file mode 120000
index 00000000..b38e66e7
--- /dev/null
+++ b/test-suite/bugs/closed/4722/tata
@@ -0,0 +1 @@
+toto
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4723.v b/test-suite/bugs/closed/4723.v
new file mode 100644
index 00000000..88848121
--- /dev/null
+++ b/test-suite/bugs/closed/4723.v
@@ -0,0 +1,28 @@
+
+Require Coq.Program.Tactics.
+
+Record Matrix (m n : nat).
+
+Definition kp {m n p q: nat} (A: Matrix m n) (B: Matrix p q):
+  Matrix (m*p) (n*q). Admitted.
+
+Fail Program Fact kp_assoc
+        (xr xc yr yc zr zc: nat)
+        (x: Matrix xr xc) (y: Matrix yr yc) (z: Matrix zr zc):
+  kp x (kp y z) = kp (kp x y) z.
+
+Ltac Obligation Tactic := admit.
+Fail Program Fact kp_assoc
+        (xr xc yr yc zr zc: nat)
+        (x: Matrix xr xc) (y: Matrix yr yc) (z: Matrix zr zc):
+  kp x (kp y z) = kp (kp x y) z.
+
+Axiom cheat : forall {A}, A.
+Obligation Tactic := apply cheat.
+
+Program Fact kp_assoc
+        (xr xc yr yc zr zc: nat)
+        (x: Matrix xr xc) (y: Matrix yr yc) (z: Matrix zr zc):
+  kp x (kp y z) = kp (kp x y) z.
+admit.
+Admitted.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4725.v b/test-suite/bugs/closed/4725.v
new file mode 100644
index 00000000..fd5e0fb6
--- /dev/null
+++ b/test-suite/bugs/closed/4725.v
@@ -0,0 +1,38 @@
+Require Import EquivDec Equivalence List Program.
+Require Import Relation_Definitions.
+Import ListNotations.
+Generalizable All Variables.
+
+Fixpoint removeV `{eqDecV : @EqDec V eqV equivV}`(x : V) (l : list V) : list V
+:=
+  match l with
+  | nil => nil
+  | y::tl => if (equiv_dec x y) then removeV x tl else y::(removeV x tl)
+  end.
+
+Lemma remove_le {V:Type}{eqV:relation V}{equivV:@Equivalence V eqV}{eqDecV :
+@EqDec V eqV equivV} (xs : list V) (x : V) :
+  length (removeV x xs) < length (x :: xs).
+  Proof. Admitted.
+
+(* Function version *)
+Set Printing Universes.
+
+Require Import Recdef.
+
+Function nubV {V:Type}{eqV:relation V}{equivV:@Equivalence V eqV}{eqDecV :
+@EqDec V eqV equivV} (l : list V) { measure length l} :=
+    match l with
+      | nil => nil
+      | x::xs => x :: @nubV V eqV equivV eqDecV (removeV x xs)
+    end.
+Proof. intros. apply remove_le. Qed.
+
+(* Program version *)
+
+Program Fixpoint nubV `{eqDecV : @EqDec V eqV equivV} (l : list V)
+        {  measure (@length V l) lt } :=
+    match l with
+      | nil => nil
+      | x::xs => x :: @nubV V eqV equivV eqDecV (removeV x xs) _
+    end.
diff --git a/test-suite/bugs/closed/4726.v b/test-suite/bugs/closed/4726.v
new file mode 100644
index 00000000..0037b6fd
--- /dev/null
+++ b/test-suite/bugs/closed/4726.v
@@ -0,0 +1,19 @@
+Set Universe Polymorphism.
+
+Definition le@{i j} : Type@{j} :=
+  (fun A : Type@{j} => A)
+  (unit : Type@{i}).  
+Definition eq@{i j} : Type@{j} := let x := le@{i j} in le@{j i}.
+
+Record Inj@{i j} (A : Type@{i}) (B : Type@{j}) : Type@{j} :=
+  { inj : A }.
+
+Monomorphic Universe u1.
+Let ty1 : Type@{u1} := Set.
+Check Inj@{Set u1}.
+(* Would fail with univ inconsistency if the universe was minimized *)
+
+Record Inj'@{i j} (A : Type@{i}) (B : Type@{j}) : Type@{j} :=
+  { inj' : A; foo : Type@{j} := eq@{i j} }.
+Fail Check Inj'@{Set u1}. (* Do not drop constraint i = j *)
+Check Inj'@{Set Set}.
diff --git a/test-suite/bugs/closed/4727.v b/test-suite/bugs/closed/4727.v
new file mode 100644
index 00000000..3854bbff
--- /dev/null
+++ b/test-suite/bugs/closed/4727.v
@@ -0,0 +1,10 @@
+(* -*- coq-prog-args: ("-emacs" "-compat" "8.4") -*- *)
+Goal forall (P : Set) (l : P) (P0 : Set) (w w0 : P0) (T : Type) (a : P * T) (o : P -> option P0),
+    (forall (l1 l2 : P) (w1 : P0), o l1 = Some w1 -> o l2 = Some w1 -> l1 = l2) ->
+    o l = Some w -> o (fst a) = Some w0 -> {w = w0} + {w <> w0} -> False.
+Proof.
+  clear; intros ???????? inj H0 H1 H2.
+  destruct H2; intuition subst.
+  eapply inj in H1; [ | eauto ].
+  progress subst. (* should succeed, used to not succeed *)
+Abort.
diff --git a/test-suite/bugs/closed/4733.v b/test-suite/bugs/closed/4733.v
new file mode 100644
index 00000000..a6ebda61
--- /dev/null
+++ b/test-suite/bugs/closed/4733.v
@@ -0,0 +1,52 @@
+(* -*- coq-prog-args: ("-emacs" "-compat" "8.4") -*- *)
+(*Suppose a user wants to declare a new list-like notation with support for singletons in both 8.4 and 8.5.  If they use*)
+Require Import Coq.Lists.List.
+Require Import Coq.Vectors.Vector.
+Import ListNotations.
+Import VectorNotations.
+Set Implicit Arguments.
+Inductive mylist T := mynil | mycons (_ : T) (_ : mylist T).
+Arguments mynil {_}, _.
+
+Delimit Scope mylist_scope with mylist.
+Bind Scope mylist_scope with mylist.
+Delimit Scope vector_scope with vector.
+
+Notation " [ ] " := mynil (format "[ ]") : mylist_scope.
+Notation " [ x ] " := (mycons x mynil) : mylist_scope.
+Notation " [ x ; .. ; y ] " := (mycons x .. (mycons y mynil) ..) : mylist_scope.
+
+(** All of these should work fine in -compat 8.4 mode, just as they do in Coq 8.4.  There needs to be a way to specify notations above so that all of these [Check]s go through in both 8.4 and 8.5 *)
+Check [ ]%mylist : mylist _.
+Check [ ]%list : list _.
+Check []%vector : Vector.t _ _.
+Check [ _ ]%mylist : mylist _.
+Check [ _ ]%list : list _.
+Check [ _ ]%vector : Vector.t _ _.
+Check [ _ ; _ ]%list : list _.
+Check [ _ ; _ ]%vector : Vector.t _ _.
+Check [ _ ; _ ]%mylist : mylist _.
+Check [ _ ; _ ; _ ]%list : list _.
+Check [ _ ; _ ; _ ]%vector : Vector.t _ _.
+Check [ _ ; _ ; _ ]%mylist : mylist _.
+Check [ _ ; _ ; _ ; _ ]%list : list _.
+Check [ _ ; _ ; _ ; _ ]%vector : Vector.t _ _.
+Check [ _ ; _ ; _ ; _ ]%mylist : mylist _.
+
+Notation " [ x ; y ; .. ; z ] " := (mycons x (mycons y .. (mycons z mynil) ..)) : mylist_scope.
+(* Now these all work, but not so in 8.4.  If we get the ability to remove notations, this section can also just be removed. *)
+Check [ ]%mylist : mylist _.
+Check [ ]%list : list _.
+Check []%vector : Vector.t _ _.
+Check [ _ ]%mylist : mylist _.
+Check [ _ ]%list : list _.
+Check [ _ ]%vector : Vector.t _ _.
+Check [ _ ; _ ]%list : list _.
+Check [ _ ; _ ]%vector : Vector.t _ _.
+Check [ _ ; _ ]%mylist : mylist _.
+Check [ _ ; _ ; _ ]%list : list _.
+Check [ _ ; _ ; _ ]%vector : Vector.t _ _.
+Check [ _ ; _ ; _ ]%mylist : mylist _.
+Check [ _ ; _ ; _ ; _ ]%list : list _.
+Check [ _ ; _ ; _ ; _ ]%vector : Vector.t _ _.
+Check [ _ ; _ ; _ ; _ ]%mylist : mylist _.
diff --git a/test-suite/bugs/closed/4737.v b/test-suite/bugs/closed/4737.v
new file mode 100644
index 00000000..84ed45e4
--- /dev/null
+++ b/test-suite/bugs/closed/4737.v
@@ -0,0 +1,9 @@
+Goal True.
+Proof.
+exact I; cycle 1.
+Qed.
+
+Goal True.
+Proof.
+exact I; swap 1 2.
+Qed.
diff --git a/test-suite/bugs/closed/4745.v b/test-suite/bugs/closed/4745.v
new file mode 100644
index 00000000..c090125e
--- /dev/null
+++ b/test-suite/bugs/closed/4745.v
@@ -0,0 +1,35 @@
+(*I get an Anomaly in the following code.
+
+```*)
+Require Vector.
+
+Module M.
+  Lemma Vector_map_map :
+    forall A B C (f : A -> B) (g : B -> C) n (v : Vector.t A n),
+      Vector.map g (Vector.map f v) = Vector.map (fun a => g (f a)) v.
+  Proof.
+    induction v; simpl; auto using f_equal.
+  Qed.
+
+  Lemma Vector_map_map_transparent :
+    forall A B C (f : A -> B) (g : B -> C) n (v : Vector.t A n),
+      Vector.map g (Vector.map f v) = Vector.map (fun a => g (f a)) v.
+  Proof.
+    induction v; simpl; auto using f_equal.
+  Defined.
+  (* Anomaly: constant not found in kind_of_head: Coq.Vectors.Vector.t_ind. Please report. *)
+
+  (* strangely, explicitly passing the principle to induction works *)
+  Lemma Vector_map_map_transparent' :
+    forall A B C (f : A -> B) (g : B -> C) n (v : Vector.t A n),
+      Vector.map g (Vector.map f v) = Vector.map (fun a => g (f a)) v.
+  Proof.
+    induction v using Vector.t_ind; simpl; auto using f_equal.
+  Defined.
+End M.
+(*```
+
+Changing any of the following things eliminates the Anomaly
+   * moving the lemma out of the module M to the top level
+   * proving the lemma as a Fixpoint instead of using induction
+   * proving the analogous lemma on lists instead of vectors*)
diff --git a/test-suite/bugs/closed/4746.v b/test-suite/bugs/closed/4746.v
new file mode 100644
index 00000000..d64cc6fe
--- /dev/null
+++ b/test-suite/bugs/closed/4746.v
@@ -0,0 +1,14 @@
+Variables P Q : nat -> Prop.
+Variable f : nat -> nat.
+
+Goal forall (x:nat), (forall y, P y -> forall z, Q z -> y=f z -> False) -> False.
+Proof.
+intros.
+ecase H with (3:=eq_refl).
+Abort.
+
+Goal forall (x:nat), (forall y, y=x -> False) -> False.
+Proof.
+intros.
+unshelve ecase H with (1:=eq_refl).
+Qed.
diff --git a/test-suite/bugs/closed/4754.v b/test-suite/bugs/closed/4754.v
new file mode 100644
index 00000000..5bb3cd1b
--- /dev/null
+++ b/test-suite/bugs/closed/4754.v
@@ -0,0 +1,35 @@
+
+Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms.
+Definition f (v : option nat) := match v with
+                                 | Some k => Some k
+                                 | None => None
+                                 end.
+
+Axioms F G : (option nat -> option nat) -> Prop.
+Axiom FG : forall f, f None = None -> F f = G f.
+
+Axiom admit : forall {T}, T.
+
+Existing Instance eq_Reflexive.
+
+Global Instance foo (A := nat)
+  : Proper ((pointwise_relation _ eq)
+              ==> eq ==> forall_relation (fun _ => Basics.flip Basics.impl))
+           (@option_rect A (fun _ => Prop)) | 0.
+exact admit.
+Qed.
+
+Global Instance bar (A := nat)
+  : Proper ((pointwise_relation _ eq)
+              ==> eq ==> eq ==> Basics.flip Basics.impl)
+           (@option_rect A (fun _ => Prop)) | 0.
+exact admit.
+Qed.
+
+Goal forall k, option_rect (fun _ => Prop) (fun v : nat => v = v /\ F f) True k.
+Proof.
+  intro.
+  pose proof (_ : (Proper (_ ==> eq ==> _) and)).
+  setoid_rewrite (FG _ _); [ | reflexivity.. ].
+  Undo.
+  setoid_rewrite (FG _ eq_refl). (* Error: Tactic failure: setoid rewrite failed: Nothing to rewrite. in 8.5 *) Admitted.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4762.v b/test-suite/bugs/closed/4762.v
new file mode 100644
index 00000000..7a87b07a
--- /dev/null
+++ b/test-suite/bugs/closed/4762.v
@@ -0,0 +1,24 @@
+Inductive myand (P Q : Prop) := myconj : P -> Q -> myand P Q.
+
+Lemma foo P Q R : R = myand P Q -> P -> Q -> R.
+Proof. intros ->; constructor; auto. Qed.
+
+Hint Extern 0 (myand _ _) => eapply foo; [reflexivity| |] : test1.
+
+Goal forall P Q R : Prop, P -> Q -> R -> myand P (myand Q R).
+Proof.
+  intros.
+  eauto with test1.
+Qed.
+
+Hint Extern 0 =>
+  match goal with
+  | |- myand _ _ => eapply foo; [reflexivity| |]
+  end : test2.
+
+Goal forall P Q R : Prop, P -> Q -> R -> myand P (myand Q R).
+Proof.
+  intros.
+  eauto with test2. (* works *)
+Qed.
+
diff --git a/test-suite/bugs/closed/4763.v b/test-suite/bugs/closed/4763.v
new file mode 100644
index 00000000..ae8ed0e6
--- /dev/null
+++ b/test-suite/bugs/closed/4763.v
@@ -0,0 +1,13 @@
+Require Import Coq.Arith.Arith Coq.Classes.Morphisms Coq.Classes.RelationClasses.
+Coercion is_true : bool >-> Sortclass.
+Global Instance: Transitive leb.
+Admitted.
+
+Goal forall x y z, leb x y -> leb y z -> True.
+  intros ??? H H'.
+  lazymatch goal with
+  | [ H : is_true (?R ?x ?y), H' : is_true (?R ?y ?z) |- _ ]
+    => pose proof (transitivity H H' : is_true (R x z))
+  end.
+  exact I.
+Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4764.v b/test-suite/bugs/closed/4764.v
new file mode 100644
index 00000000..e545cc1b
--- /dev/null
+++ b/test-suite/bugs/closed/4764.v
@@ -0,0 +1,5 @@
+Notation prop_fun x y := (fun (x : Prop) => y).
+Definition foo := fun (p : Prop) => p.
+Definition bar := fun (_ : Prop) => O.
+Print foo.
+Print bar.
diff --git a/test-suite/bugs/closed/4769.v b/test-suite/bugs/closed/4769.v
new file mode 100644
index 00000000..d87906f3
--- /dev/null
+++ b/test-suite/bugs/closed/4769.v
@@ -0,0 +1,94 @@
+
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-nois" "-R" "." "Top" "-top" "bug_hom_anom_10") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 156 lines to 41 lines, then from 237 lines to 45 lines, then from 163 lines to 66 lines, then from 342 lines to 121 lines, then from 353 lines to 184 lines, then from 343 lines to 255 lines, then from 435 lines to 322 lines, then from 475 lines to 351 lines, then from 442 lines to 377 lines, then from 505 lines to 410 lines, then from 591 lines to 481 lines, then from 596 lines to 535 lines, then from 647 lines to 570 lines, then from 669 lines to 596 lines, then from 687 lines to 620 lines, then from 728 lines to 652 lines, then from 1384 lines to 683 lines, then from 984 lines to 707 lines, then from 1124 lines to 734 lines, then from 775 lines to 738 lines, then from 950 lines to 763 lines, then from 857 lines to 798 lines, then from 983 lines to 752 lines, then from 1598 lines to 859 lines, then from 873 lines to 859 lines, then from 875 lines to 862 lines, then from 901 lines to 863 lines, then from 1047 lines to 865 lines, then from 929 lines to 871 lines, then from 989 lines to 884 lines, then from 900 lines to 884 lines, then from 884 lines to 751 lines, then from 763 lines to 593 lines, then from 482 lines to 232 lines, then from 416 lines to 227 lines, then from 290 lines to 231 lines, then from 348 lines to 235 lines, then from 249 lines to 235 lines, then from 249 lines to 172 lines, then from 186 lines to 172 lines, then from 140 lines to 113 lines, then from 127 lines to 113 lines *) (* coqc version trunk (June 2016) compiled on Jun 2 2016 10:16:20 with OCaml 4.02.3
+   coqtop version trunk (June 2016) *)
+
+Reserved Notation "x -> y" (at level 99, right associativity, y at level 200).
+Reserved Notation "x * y" (at level 40, left associativity).
+Delimit Scope type_scope with type.
+Open Scope type_scope.
+Global Set Universe Polymorphism.
+Notation "A -> B" := (forall (_ : A), B) : type_scope.
+Set Implicit Arguments.
+Global Set Nonrecursive Elimination Schemes.
+Record prod (A B : Type) := pair { fst : A ; snd : B }.
+Notation "x * y" := (prod x y) : type_scope.
+Axiom admit : forall {T}, T.
+Delimit Scope function_scope with function.
+Notation compose := (fun g f x => g (f x)).
+Notation "g 'o' f" := (compose g%function f%function) (at level 40, left associativity) : function_scope.
+Record PreCategory :=
+  Build_PreCategory {
+      object :> Type;
+      morphism : object -> object -> Type;
+      identity : forall x, morphism x x }.
+Bind Scope category_scope with PreCategory.
+Record Functor (C D : PreCategory) := { object_of :> C -> D }.
+Bind Scope functor_scope with Functor.
+Class Isomorphic {C : PreCategory} (s d : C) := {}.
+Definition oppositeC (C : PreCategory) : PreCategory
+  := @Build_PreCategory C (fun s d => morphism C d s) admit.
+Notation "C ^op" := (oppositeC 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) (object_of F).
+Definition set_cat : PreCategory := @Build_PreCategory Type (fun x y => x -> y) admit.
+Definition prodC (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)
+       admit.
+Infix "*" := prodC : category_scope.
+Section composition.
+  Variables B C D E : PreCategory.
+  Definition composeF (G : Functor D E) (F : Functor C D) : Functor C E := Build_Functor C E (fun c => G (F c)).
+End composition.
+Infix "o" := composeF : functor_scope.
+Definition fstF {C D} : Functor (C * D) C := admit.
+Definition sndF {C D} : Functor (C * D) D := admit.
+Definition prodF C D D' (F : Functor C D) (F' : Functor C D') : Functor C (D * D') := admit.
+Local Infix "*" := prodF : functor_scope.
+Definition pairF C D C' D' (F : Functor C D) (F' : Functor C' D') : Functor (C * C') (D * D')
+  := (F o fstF) * (F' o sndF).
+Section hom_functor.
+  Variable C : PreCategory.
+  Local Notation obj_of c'c :=
+    ((morphism
+        C
+        (fst (c'c : object (C^op * C)))
+        (snd (c'c : object (C^op * C))))).
+  Definition hom_functor : Functor (C^op * C) set_cat
+    := Build_Functor (C^op * C) set_cat (fun c'c => obj_of c'c).
+End hom_functor.
+Definition identityF C : Functor C C := admit.
+Definition functor_category (C D : PreCategory) : PreCategory
+  := @Build_PreCategory (Functor C D) admit admit.
+Local Notation "C -> D" := (functor_category C D) : category_scope.
+Definition NaturalIsomorphism (C D : PreCategory) F G := @Isomorphic (C -> D) F G.
+
+Section Adjunction.
+  Variables C D : PreCategory.
+  Variable F : Functor C D.
+  Variable G : Functor D C.
+  
+  Record AdjunctionHom :=
+    {
+      mate_of : @NaturalIsomorphism
+                  (prodC (oppositeC C) D)
+                  (@set_cat)
+                  (@composeF
+                     (prodC (oppositeC C) D)
+                     (prodC (oppositeC D) D)
+                     (@set_cat) (@hom_functor D)
+                     (@pairF (oppositeC C)
+                             (oppositeC D) D D
+                             (@oppositeF C D F) (identityF D)))
+                  (@composeF
+                     (prodC (oppositeC C) D)
+                     (prodC (oppositeC C) C)
+                     (@set_cat) (@hom_functor C)
+                     (@pairF (oppositeC C)
+                             (oppositeC C) D C
+                             (identityF (oppositeC C)) G))
+    }.
+End Adjunction.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4772.v b/test-suite/bugs/closed/4772.v
new file mode 100644
index 00000000..c3109fa3
--- /dev/null
+++ b/test-suite/bugs/closed/4772.v
@@ -0,0 +1,6 @@
+
+Record TruncType := BuildTruncType {
+  trunctype_type : Type
+}.
+
+Fail Arguments BuildTruncType _ _ {_}. (* This should fail *)
diff --git a/test-suite/bugs/closed/4780.v b/test-suite/bugs/closed/4780.v
new file mode 100644
index 00000000..4cec4318
--- /dev/null
+++ b/test-suite/bugs/closed/4780.v
@@ -0,0 +1,106 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-R" "." "Top" "-top" "bug_bad_induction_01") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 1889 lines to 144 lines, then from 158 lines to 144 lines *)
+(* coqc version 8.5pl1 (April 2016) compiled on Apr 18 2016 14:48:5 with OCaml 4.02.3
+   coqtop version 8.5pl1 (April 2016) *)
+Axiom proof_admitted : False.
+Tactic Notation "admit" := abstract case proof_admitted.
+Global Set Universe Polymorphism.
+Global Set Asymmetric Patterns.
+Notation "'exists' x .. y , p" := (sigT (fun x => .. (sigT (fun y => p)) ..))
+  (at level 200, x binder, right associativity,
+   format "'[' 'exists'  '/  ' x  ..  y ,  '/  ' p ']'")
+  : type_scope.
+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 pr1 := projT1.
+Notation pr2 := projT2.
+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.
+Arguments idpath {A a} , [A] a.
+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.
+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.
+Instance transitive_paths {A} : Transitive (@paths A) | 0 := @concat A.
+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 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.
+Lemma transport_compose {A B} {x y : A} (P : B -> Type) (f : A -> B)
+  (p : x = y) (z : P (f x))
+  : transport (fun x => P (f x)) p z  =  transport P (ap f p) z.
+admit.
+Defined.
+Local Open Scope path_scope.
+Generalizable Variables X A B C f g n.
+Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P)
+  (pq : {p : u.1 = v.1 &  p # u.2 = v.2})
+  : u = v
+  := match pq with
+       | existT p q =>
+         match u, v return (forall p0 : (u.1 = v.1), (p0 # u.2 = v.2) -> (u=v)) with
+           | (x;y), (x';y') => fun p1 q1 =>
+             match p1 in (_ = x'') return (forall y'', (p1 # y = y'') -> (x;y)=(x'';y'')) with
+               | idpath => fun y' q2 =>
+                 match q2 in (_ = y'') return (x;y) = (x;y'') with
+                   | idpath => 1
+                 end
+             end y' q1
+         end p q
+     end.
+Definition path_sigma {A : Type} (P : A -> Type) (u v : sigT P)
+  (p : u.1 = v.1) (q : p # u.2 = v.2)
+  : u = v
+  := path_sigma_uncurried P u v (p;q).
+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.
+Definition projT2_path `{P : A -> Type} {u v : sigT P} (p : u = v)
+  : p..1 # u.2 = v.2
+  := (transport_compose P (@projT1 _ _) p u.2)^
+     @ (@apD {x:A & P x} _ (@projT2 _ _) _ _ p).
+Notation "p ..2" := (projT2_path p) (at level 3) : fibration_scope.
+Definition eta_path_sigma_uncurried `{P : A -> Type} {u v : sigT P}
+  (p : u = v)
+  : path_sigma_uncurried _ _ _ (p..1; p..2) = p.
+admit.
+Defined.
+Definition eta_path_sigma `{P : A -> Type} {u v : sigT P} (p : u = v)
+  : path_sigma _ _ _ (p..1) (p..2) = p
+  := eta_path_sigma_uncurried p.
+
+Definition path_path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P)
+  (p q : u = v)
+  (rs : {r : p..1 = q..1 & transport (fun x => transport P x u.2 = v.2) r p..2 = q..2})
+  : p = q.
+Proof.
+  destruct rs, p, u.
+  etransitivity; [ | apply eta_path_sigma ].
+  simpl in *.
+  induction p0.
+  admit.
+Defined.
+
diff --git a/test-suite/bugs/closed/4782.v b/test-suite/bugs/closed/4782.v
new file mode 100644
index 00000000..dbd71035
--- /dev/null
+++ b/test-suite/bugs/closed/4782.v
@@ -0,0 +1,24 @@
+(* About typing of with bindings *)
+
+Record r : Type := mk_r { type : Type; cond : type -> Prop }.
+
+Inductive p : Prop := consp : forall (e : r) (x : type e), cond e x -> p.
+
+Goal p.
+Fail apply consp with (fun _ : bool => mk_r unit (fun x => True)) nil.
+ 
+(* A simplification of an example from coquelicot, which was failing
+   at some time after a fix #4782 was committed. *)
+
+Record T := { dom : Type }.
+Definition pairT A B := {| dom := (dom A * dom B)%type |}.
+Class C (A:Type).
+Parameter B:T.
+Instance c (A:T) : C (dom A).
+Instance cn : C (dom B).
+Parameter F : forall A:T, C (dom A) -> forall x:dom A, x=x -> A = A.
+Set Typeclasses Debug.
+Goal forall (A:T) (x:dom A), pairT A A = pairT A A.
+intros.
+apply (F _ _)  with (x,x).
+  
diff --git a/test-suite/bugs/closed/4785.v b/test-suite/bugs/closed/4785.v
new file mode 100644
index 00000000..c3c97d3f
--- /dev/null
+++ b/test-suite/bugs/closed/4785.v
@@ -0,0 +1,45 @@
+Require Coq.Lists.List Coq.Vectors.Vector.
+Require Coq.Compat.Coq85.
+
+Module A.
+Import Coq.Lists.List Coq.Vectors.Vector.
+Import ListNotations.
+Check [ ]%list : list _.
+Import VectorNotations ListNotations.
+Delimit Scope vector_scope with vector.
+Check [ ]%vector : Vector.t _ _.
+Check []%vector : Vector.t _ _.
+Check [ ]%list : list _.
+Check []%list : list _.
+
+Goal True.
+  idtac; []. (* Check that vector notations don't break the [ | .. | ] syntax of Ltac *)
+Abort.
+
+Inductive mylist A := mynil | mycons (x : A) (xs : mylist A).
+Delimit Scope mylist_scope with mylist.
+Bind Scope mylist_scope with mylist.
+Arguments mynil {_}, _.
+Arguments mycons {_} _ _.
+Notation " [] " := mynil (compat "8.5") : mylist_scope.
+Notation " [ ] " := mynil (format "[ ]") : mylist_scope.
+Notation " [ x ] " := (mycons x nil) : mylist_scope.
+Notation " [ x ; y ; .. ; z ] " :=  (mycons x (mycons y .. (mycons z nil) ..)) : mylist_scope.
+
+Import Coq.Compat.Coq85.
+Locate Module VectorNotations.
+Import VectorDef.VectorNotations.
+
+Check []%vector : Vector.t _ _.
+Check []%mylist : mylist _.
+Check [ ]%mylist : mylist _.
+Check [ ]%list : list _.
+End A.
+
+Module B.
+Import Coq.Compat.Coq85.
+
+Goal True.
+  idtac; []. (* Check that importing the compat file doesn't break the [ | .. | ] syntax of Ltac *)
+Abort.
+End B.
diff --git a/test-suite/bugs/closed/4785_compat_85.v b/test-suite/bugs/closed/4785_compat_85.v
new file mode 100644
index 00000000..9d65840a
--- /dev/null
+++ b/test-suite/bugs/closed/4785_compat_85.v
@@ -0,0 +1,46 @@
+(* -*- coq-prog-args: ("-emacs" "-compat" "8.5") -*- *)
+Require Coq.Lists.List Coq.Vectors.Vector.
+Require Coq.Compat.Coq85.
+
+Module A.
+Import Coq.Lists.List Coq.Vectors.Vector.
+Import ListNotations.
+Check [ ]%list : list _.
+Import VectorNotations ListNotations.
+Delimit Scope vector_scope with vector.
+Check [ ]%vector : Vector.t _ _.
+Check []%vector : Vector.t _ _.
+Check [ ]%list : list _.
+Fail Check []%list : list _.
+
+Goal True.
+  idtac; [ ]. (* Note that vector notations break the [ | .. | ] syntax of Ltac *)
+Abort.
+
+Inductive mylist A := mynil | mycons (x : A) (xs : mylist A).
+Delimit Scope mylist_scope with mylist.
+Bind Scope mylist_scope with mylist.
+Arguments mynil {_}, _.
+Arguments mycons {_} _ _.
+Notation " [] " := mynil (compat "8.5") : mylist_scope.
+Notation " [ ] " := mynil (format "[ ]") : mylist_scope.
+Notation " [ x ] " := (mycons x nil) : mylist_scope.
+Notation " [ x ; y ; .. ; z ] " :=  (mycons x (mycons y .. (mycons z nil) ..)) : mylist_scope.
+
+Import Coq.Compat.Coq85.
+Locate Module VectorNotations.
+Import VectorDef.VectorNotations.
+
+Check []%vector : Vector.t _ _.
+Check []%mylist : mylist _.
+Check [ ]%mylist : mylist _.
+Check [ ]%list : list _.
+End A.
+
+Module B.
+Import Coq.Compat.Coq85.
+
+Goal True.
+  idtac; []. (* Check that importing the compat file doesn't break the [ | .. | ] syntax of Ltac *)
+Abort.
+End B.
diff --git a/test-suite/bugs/closed/4787.v b/test-suite/bugs/closed/4787.v
new file mode 100644
index 00000000..b586cba5
--- /dev/null
+++ b/test-suite/bugs/closed/4787.v
@@ -0,0 +1,9 @@
+(* [Unset Bracketing Last Introduction Pattern] was not working *)
+
+Unset Bracketing Last Introduction Pattern.
+
+Goal forall T (x y : T * T), fst x = fst y /\ snd x = snd y -> x = y.
+do 10 ((intros [] || intro); simpl); reflexivity.
+Qed.
+
+
diff --git a/test-suite/bugs/closed/4798.v b/test-suite/bugs/closed/4798.v
new file mode 100644
index 00000000..dbc3d46f
--- /dev/null
+++ b/test-suite/bugs/closed/4798.v
@@ -0,0 +1,3 @@
+Check match 2 with 0 => 0 | S n => n end.
+Notation "|" := 1 (compat "8.4").
+Check match 2 with 0 => 0 | S n => n end. (* fails *)
diff --git a/test-suite/bugs/closed/4811.v b/test-suite/bugs/closed/4811.v
new file mode 100644
index 00000000..a9149626
--- /dev/null
+++ b/test-suite/bugs/closed/4811.v
@@ -0,0 +1,1685 @@
+(* Test about a slowness of f_equal in 8.5pl1 *)
+
+(* Submitted by Jason Gross *)
+
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-R" "src" "Crypto" "-R" "Bedrock" "Bedrock" "-R" "coqprime-8.5/Coqprime" "Coqprime" "-top" "GF255192") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 162 lines to 23 lines, then from 245 lines to 95 lines, then from 198 lines to 101 lines, then from 654 lines to 452 lines, then from 591 lines to 505 lines, then from 1770 lines to 580 lines, then from 2238 lines to 1715 lines, then from 1776 lines to 1738 lines, then from 1750 lines to 1679 lines, then from 1693 lines to 1679 lines *)
+(* coqc version 8.5pl1 (April 2016) compiled on Apr 18 2016 14:48:5 with OCaml 4.02.3
+   coqtop version 8.5pl1 (April 2016) *)
+Require Coq.ZArith.ZArith.
+
+Import Coq.ZArith.ZArith.
+
+Axiom F : Z -> Set.
+Definition Let_In {A P} (x : A) (f : forall y : A, P y)
+  := let y := x in f y.
+Local Open Scope Z_scope.
+Definition modulus : Z := 2^255 - 19.
+Axiom decode : list Z -> F modulus.
+Goal    forall x9 x8 x7 x6 x5 x4 x3 x2 x1 x0 y9 y8 y7 y6 y5 y4 y3 y2 y1 y0 : Z,
+   let Zmul := Z.mul in
+   let Zadd := Z.add in
+   let Zsub := Z.sub in
+   let Zpow_pos := Z.pow_pos in
+   @eq (F (Zsub (Zpow_pos (Zpos (xO xH)) (xI (xI (xI (xI (xI (xI (xI xH)))))))) (Zpos (xI (xI (xO (xO xH)))))))
+     (@decode
+        (@Let_In Z (fun _ : Z => list Z)
+           (Zadd (Zmul x0 y0)
+              (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                 (Zadd
+                    (Zadd
+                       (Zadd
+                          (Zadd
+                             (Zadd
+                                (Zadd
+                                   (Zadd (Zadd (Zmul (Zmul x9 y1) (Zpos (xO xH))) (Zmul x8 y2)) (Zmul (Zmul x7 y3) (Zpos (xO xH))))
+                                   (Zmul x6 y4)) (Zmul (Zmul x5 y5) (Zpos (xO xH)))) (Zmul x4 y6))
+                          (Zmul (Zmul x3 y7) (Zpos (xO xH)))) (Zmul x2 y8)) (Zmul (Zmul x1 y9) (Zpos (xO xH))))))
+           (fun z : Z =>
+            @Let_In Z (fun _ : Z => list Z)
+              (Zadd (Z.shiftr z (Zpos (xO (xI (xO (xI xH))))))
+                 (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1))
+                    (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                       (Zadd
+                          (Zadd
+                             (Zadd (Zadd (Zadd (Zadd (Zadd (Zmul x9 y2) (Zmul x8 y3)) (Zmul x7 y4)) (Zmul x6 y5)) (Zmul x5 y6))
+                                (Zmul x4 y7)) (Zmul x3 y8)) (Zmul x2 y9)))))
+              (fun z0 : Z =>
+               @Let_In Z (fun _ : Z => list Z)
+                 (Zadd (Z.shiftr z0 (Zpos (xI (xO (xO (xI xH))))))
+                    (Zadd (Zadd (Zadd (Zmul x2 y0) (Zmul (Zmul x1 y1) (Zpos (xO xH)))) (Zmul x0 y2))
+                       (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                          (Zadd
+                             (Zadd
+                                (Zadd
+                                   (Zadd
+                                      (Zadd (Zadd (Zmul (Zmul x9 y3) (Zpos (xO xH))) (Zmul x8 y4))
+                                         (Zmul (Zmul x7 y5) (Zpos (xO xH)))) (Zmul x6 y6)) (Zmul (Zmul x5 y7) (Zpos (xO xH))))
+                                (Zmul x4 y8)) (Zmul (Zmul x3 y9) (Zpos (xO xH)))))))
+                 (fun z1 : Z =>
+                  @Let_In Z (fun _ : Z => list Z)
+                    (Zadd (Z.shiftr z1 (Zpos (xO (xI (xO (xI xH))))))
+                       (Zadd (Zadd (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) (Zmul x1 y2)) (Zmul x0 y3))
+                          (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                             (Zadd (Zadd (Zadd (Zadd (Zadd (Zmul x9 y4) (Zmul x8 y5)) (Zmul x7 y6)) (Zmul x6 y7)) (Zmul x5 y8))
+                                (Zmul x4 y9)))))
+                    (fun z2 : Z =>
+                     @Let_In Z (fun _ : Z => list Z)
+                       (Zadd (Z.shiftr z2 (Zpos (xI (xO (xO (xI xH))))))
+                          (Zadd
+                             (Zadd
+                                (Zadd (Zadd (Zadd (Zmul x4 y0) (Zmul (Zmul x3 y1) (Zpos (xO xH)))) (Zmul x2 y2))
+                                   (Zmul (Zmul x1 y3) (Zpos (xO xH)))) (Zmul x0 y4))
+                             (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                (Zadd
+                                   (Zadd
+                                      (Zadd (Zadd (Zmul (Zmul x9 y5) (Zpos (xO xH))) (Zmul x8 y6))
+                                         (Zmul (Zmul x7 y7) (Zpos (xO xH)))) (Zmul x6 y8)) (Zmul (Zmul x5 y9) (Zpos (xO xH)))))))
+                       (fun z3 : Z =>
+                        @Let_In Z (fun _ : Z => list Z)
+                          (Zadd (Z.shiftr z3 (Zpos (xO (xI (xO (xI xH))))))
+                             (Zadd
+                                (Zadd (Zadd (Zadd (Zadd (Zadd (Zmul x5 y0) (Zmul x4 y1)) (Zmul x3 y2)) (Zmul x2 y3)) (Zmul x1 y4))
+                                   (Zmul x0 y5))
+                                (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                   (Zadd (Zadd (Zadd (Zmul x9 y6) (Zmul x8 y7)) (Zmul x7 y8)) (Zmul x6 y9)))))
+                          (fun z4 : Z =>
+                           @Let_In Z (fun _ : Z => list Z)
+                             (Zadd (Z.shiftr z4 (Zpos (xI (xO (xO (xI xH))))))
+                                (Zadd
+                                   (Zadd
+                                      (Zadd
+                                         (Zadd
+                                            (Zadd (Zadd (Zadd (Zmul x6 y0) (Zmul (Zmul x5 y1) (Zpos (xO xH)))) (Zmul x4 y2))
+                                               (Zmul (Zmul x3 y3) (Zpos (xO xH)))) (Zmul x2 y4)) (Zmul (Zmul x1 y5) (Zpos (xO xH))))
+                                      (Zmul x0 y6))
+                                   (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                      (Zadd (Zadd (Zmul (Zmul x9 y7) (Zpos (xO xH))) (Zmul x8 y8))
+                                         (Zmul (Zmul x7 y9) (Zpos (xO xH)))))))
+                             (fun z5 : Z =>
+                              @Let_In Z (fun _ : Z => list Z)
+                                (Zadd (Z.shiftr z5 (Zpos (xO (xI (xO (xI xH))))))
+                                   (Zadd
+                                      (Zadd
+                                         (Zadd
+                                            (Zadd
+                                               (Zadd (Zadd (Zadd (Zadd (Zmul x7 y0) (Zmul x6 y1)) (Zmul x5 y2)) (Zmul x4 y3))
+                                                  (Zmul x3 y4)) (Zmul x2 y5)) (Zmul x1 y6)) (Zmul x0 y7))
+                                      (Zmul (Zpos (xI (xI (xO (xO xH))))) (Zadd (Zmul x9 y8) (Zmul x8 y9)))))
+                                (fun z6 : Z =>
+                                 @Let_In Z (fun _ : Z => list Z)
+                                   (Zadd (Z.shiftr z6 (Zpos (xI (xO (xO (xI xH))))))
+                                      (Zadd
+                                         (Zadd
+                                            (Zadd
+                                               (Zadd
+                                                  (Zadd
+                                                     (Zadd
+                                                        (Zadd
+                                                           (Zadd (Zadd (Zmul x8 y0) (Zmul (Zmul x7 y1) (Zpos (xO xH)))) (Zmul x6 y2))
+                                                           (Zmul (Zmul x5 y3) (Zpos (xO xH)))) (Zmul x4 y4))
+                                                     (Zmul (Zmul x3 y5) (Zpos (xO xH)))) (Zmul x2 y6))
+                                               (Zmul (Zmul x1 y7) (Zpos (xO xH)))) (Zmul x0 y8))
+                                         (Zmul (Zmul (Zmul (Zpos (xI (xI (xO (xO xH))))) x9) y9) (Zpos (xO xH)))))
+                                   (fun z7 : Z =>
+                                    @Let_In Z (fun _ : Z => list Z)
+                                      (Zadd (Z.shiftr z7 (Zpos (xO (xI (xO (xI xH))))))
+                                         (Zadd
+                                            (Zadd
+                                               (Zadd
+                                                  (Zadd
+                                                     (Zadd
+                                                        (Zadd
+                                                           (Zadd (Zadd (Zadd (Zmul x9 y0) (Zmul x8 y1)) (Zmul x7 y2)) (Zmul x6 y3))
+                                                           (Zmul x5 y4)) (Zmul x4 y5)) (Zmul x3 y6)) (Zmul x2 y7))
+                                               (Zmul x1 y8)) (Zmul x0 y9)))
+                                      (fun z8 : Z =>
+                                       @Let_In Z (fun _ : Z => list Z)
+                                         (Zadd (Zmul (Zpos (xI (xI (xO (xO xH))))) (Z.shiftr z8 (Zpos (xI (xO (xO (xI xH)))))))
+                                            (Z.land z
+                                               (Zpos
+                                                  (xI
+                                                     (xI
+                                                        (xI
+                                                           (xI
+                                                              (xI
+                                                                 (xI
+                                                                    (xI
+                                                                       (xI
+                                                                          (xI
+                                                                             (xI
+                                                                                (xI
+                                                                                   (xI
+                                                                                      (xI
+                                                                                         (xI
+                                                                                            (xI
+                                                                                               (xI
+                                                                                                  (xI
+                                                                                                     (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))))
+                                         (fun z9 : Z =>
+                                          @cons Z
+                                            (Z.land z9
+                                               (Zpos
+                                                  (xI
+                                                     (xI
+                                                        (xI
+                                                           (xI
+                                                              (xI
+                                                                 (xI
+                                                                    (xI
+                                                                       (xI
+                                                                          (xI
+                                                                             (xI
+                                                                                (xI
+                                                                                   (xI
+                                                                                      (xI
+                                                                                         (xI
+                                                                                            (xI
+                                                                                               (xI
+                                                                                                  (xI
+                                                                                                     (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))))
+                                            (@cons Z
+                                               (Zadd (Z.shiftr z9 (Zpos (xO (xI (xO (xI xH))))))
+                                                  (Z.land z0
+                                                     (Zpos
+                                                        (xI
+                                                           (xI
+                                                              (xI
+                                                                 (xI
+                                                                    (xI
+                                                                       (xI
+                                                                          (xI
+                                                                             (xI
+                                                                                (xI
+                                                                                   (xI
+                                                                                      (xI
+                                                                                         (xI
+                                                                                            (xI
+                                                                                               (xI
+                                                                                                  (xI
+                                                                                                     (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))))
+                                               (@cons Z
+                                                  (Z.land z1
+                                                     (Zpos
+                                                        (xI
+                                                           (xI
+                                                              (xI
+                                                                 (xI
+                                                                    (xI
+                                                                       (xI
+                                                                          (xI
+                                                                             (xI
+                                                                                (xI
+                                                                                   (xI
+                                                                                      (xI
+                                                                                         (xI
+                                                                                            (xI
+                                                                                               (xI
+                                                                                                  (xI
+                                                                                                     (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))))
+                                                  (@cons Z
+                                                     (Z.land z2
+                                                        (Zpos
+                                                           (xI
+                                                              (xI
+                                                                 (xI
+                                                                    (xI
+                                                                       (xI
+                                                                          (xI
+                                                                             (xI
+                                                                                (xI
+                                                                                   (xI
+                                                                                      (xI
+                                                                                         (xI
+                                                                                            (xI
+                                                                                               (xI
+                                                                                                  (xI
+                                                                                                     (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))
+                                                     (@cons Z
+                                                        (Z.land z3
+                                                           (Zpos
+                                                              (xI
+                                                                 (xI
+                                                                    (xI
+                                                                       (xI
+                                                                          (xI
+                                                                             (xI
+                                                                                (xI
+                                                                                   (xI
+                                                                                      (xI
+                                                                                         (xI
+                                                                                            (xI
+                                                                                               (xI
+                                                                                                  (xI
+                                                                                                     (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))))
+                                                        (@cons Z
+                                                           (Z.land z4
+                                                              (Zpos
+                                                                 (xI
+                                                                    (xI
+                                                                       (xI
+                                                                          (xI
+                                                                             (xI
+                                                                                (xI
+                                                                                   (xI
+                                                                                      (xI
+                                                                                         (xI
+                                                                                            (xI
+                                                                                               (xI
+                                                                                                  (xI
+                                                                                                     (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))
+                                                           (@cons Z
+                                                              (Z.land z5
+                                                                 (Zpos
+                                                                    (xI
+                                                                       (xI
+                                                                          (xI
+                                                                             (xI
+                                                                                (xI
+                                                                                   (xI
+                                                                                      (xI
+                                                                                         (xI
+                                                                                            (xI
+                                                                                               (xI
+                                                                                                  (xI
+                                                                                                     (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))))
+                                                              (@cons Z
+                                                                 (Z.land z6
+                                                                    (Zpos
+                                                                       (xI
+                                                                          (xI
+                                                                             (xI
+                                                                                (xI
+                                                                                   (xI
+                                                                                      (xI
+                                                                                         (xI
+                                                                                            (xI
+                                                                                               (xI
+                                                                                                  (xI
+                                                                                                     (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))
+                                                                 (@cons Z
+                                                                    (Z.land z7
+                                                                       (Zpos
+                                                                          (xI
+                                                                             (xI
+                                                                                (xI
+                                                                                   (xI
+                                                                                      (xI
+                                                                                         (xI
+                                                                                            (xI
+                                                                                               (xI
+                                                                                                  (xI
+                                                                                                     (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))))
+                                                                    (@cons Z
+                                                                       (Z.land z8
+                                                                          (Zpos
+                                                                             (xI
+                                                                                (xI
+                                                                                   (xI
+                                                                                      (xI
+                                                                                         (xI
+                                                                                            (xI
+                                                                                               (xI
+                                                                                                  (xI
+                                                                                                     (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI
+                                                                                                       (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))
+                                                                       (@nil Z)))))))))))))))))))))))
+     (@decode
+        (@cons Z
+           (Z.land
+              (Zadd
+                 (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                    (Z.shiftr
+                       (Zadd
+                          (Z.shiftr
+                             (Zadd
+                                (Z.shiftr
+                                   (Zadd
+                                      (Z.shiftr
+                                         (Zadd
+                                            (Z.shiftr
+                                               (Zadd
+                                                  (Z.shiftr
+                                                     (Zadd
+                                                        (Z.shiftr
+                                                           (Zadd
+                                                              (Z.shiftr
+                                                                 (Zadd
+                                                                    (Z.shiftr
+                                                                       (Zadd
+                                                                          (Z.shiftr
+                                                                             (Zadd (Zmul x0 y0)
+                                                                                (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                                   (Zadd
+                                                                                      (Zadd
+                                                                                         (Zadd
+                                                                                            (Zadd
+                                                                                               (Zadd
+                                                                                                  (Zadd
+                                                                                                     (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zmul
+                                                                                                       (Zmul x9 y1)
+                                                                                                       (Zpos (xO xH)))
+                                                                                                       (Zmul x8 y2))
+                                                                                                       (Zmul
+                                                                                                       (Zmul x7 y3)
+                                                                                                       (Zpos (xO xH))))
+                                                                                                     (Zmul x6 y4))
+                                                                                                  (Zmul (Zmul x5 y5) (Zpos (xO xH))))
+                                                                                               (Zmul x4 y6))
+                                                                                            (Zmul (Zmul x3 y7) (Zpos (xO xH))))
+                                                                                         (Zmul x2 y8))
+                                                                                      (Zmul (Zmul x1 y9) (Zpos (xO xH))))))
+                                                                             (Zpos (xO (xI (xO (xI xH))))))
+                                                                          (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1))
+                                                                             (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                                (Zadd
+                                                                                   (Zadd
+                                                                                      (Zadd
+                                                                                         (Zadd
+                                                                                            (Zadd
+                                                                                               (Zadd
+                                                                                                  (Zadd (Zmul x9 y2) (Zmul x8 y3))
+                                                                                                  (Zmul x7 y4))
+                                                                                               (Zmul x6 y5))
+                                                                                            (Zmul x5 y6))
+                                                                                         (Zmul x4 y7)) (Zmul x3 y8))
+                                                                                   (Zmul x2 y9))))) (Zpos (xI (xO (xO (xI xH))))))
+                                                                    (Zadd
+                                                                       (Zadd (Zadd (Zmul x2 y0) (Zmul (Zmul x1 y1) (Zpos (xO xH))))
+                                                                          (Zmul x0 y2))
+                                                                       (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                          (Zadd
+                                                                             (Zadd
+                                                                                (Zadd
+                                                                                   (Zadd
+                                                                                      (Zadd
+                                                                                         (Zadd (Zmul (Zmul x9 y3) (Zpos (xO xH)))
+                                                                                            (Zmul x8 y4))
+                                                                                         (Zmul (Zmul x7 y5) (Zpos (xO xH))))
+                                                                                      (Zmul x6 y6))
+                                                                                   (Zmul (Zmul x5 y7) (Zpos (xO xH))))
+                                                                                (Zmul x4 y8)) (Zmul (Zmul x3 y9) (Zpos (xO xH)))))))
+                                                                 (Zpos (xO (xI (xO (xI xH))))))
+                                                              (Zadd
+                                                                 (Zadd (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) (Zmul x1 y2))
+                                                                    (Zmul x0 y3))
+                                                                 (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                    (Zadd
+                                                                       (Zadd
+                                                                          (Zadd (Zadd (Zadd (Zmul x9 y4) (Zmul x8 y5)) (Zmul x7 y6))
+                                                                             (Zmul x6 y7)) (Zmul x5 y8))
+                                                                       (Zmul x4 y9))))) (Zpos (xI (xO (xO (xI xH))))))
+                                                        (Zadd
+                                                           (Zadd
+                                                              (Zadd
+                                                                 (Zadd (Zadd (Zmul x4 y0) (Zmul (Zmul x3 y1) (Zpos (xO xH))))
+                                                                    (Zmul x2 y2)) (Zmul (Zmul x1 y3) (Zpos (xO xH))))
+                                                              (Zmul x0 y4))
+                                                           (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                              (Zadd
+                                                                 (Zadd
+                                                                    (Zadd (Zadd (Zmul (Zmul x9 y5) (Zpos (xO xH))) (Zmul x8 y6))
+                                                                       (Zmul (Zmul x7 y7) (Zpos (xO xH))))
+                                                                    (Zmul x6 y8)) (Zmul (Zmul x5 y9) (Zpos (xO xH)))))))
+                                                     (Zpos (xO (xI (xO (xI xH))))))
+                                                  (Zadd
+                                                     (Zadd
+                                                        (Zadd
+                                                           (Zadd (Zadd (Zadd (Zmul x5 y0) (Zmul x4 y1)) (Zmul x3 y2)) (Zmul x2 y3))
+                                                           (Zmul x1 y4)) (Zmul x0 y5))
+                                                     (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                        (Zadd (Zadd (Zadd (Zmul x9 y6) (Zmul x8 y7)) (Zmul x7 y8)) (Zmul x6 y9)))))
+                                               (Zpos (xI (xO (xO (xI xH))))))
+                                            (Zadd
+                                               (Zadd
+                                                  (Zadd
+                                                     (Zadd
+                                                        (Zadd
+                                                           (Zadd (Zadd (Zmul x6 y0) (Zmul (Zmul x5 y1) (Zpos (xO xH)))) (Zmul x4 y2))
+                                                           (Zmul (Zmul x3 y3) (Zpos (xO xH)))) (Zmul x2 y4))
+                                                     (Zmul (Zmul x1 y5) (Zpos (xO xH)))) (Zmul x0 y6))
+                                               (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                  (Zadd (Zadd (Zmul (Zmul x9 y7) (Zpos (xO xH))) (Zmul x8 y8))
+                                                     (Zmul (Zmul x7 y9) (Zpos (xO xH))))))) (Zpos (xO (xI (xO (xI xH))))))
+                                      (Zadd
+                                         (Zadd
+                                            (Zadd
+                                               (Zadd
+                                                  (Zadd (Zadd (Zadd (Zadd (Zmul x7 y0) (Zmul x6 y1)) (Zmul x5 y2)) (Zmul x4 y3))
+                                                     (Zmul x3 y4)) (Zmul x2 y5)) (Zmul x1 y6)) (Zmul x0 y7))
+                                         (Zmul (Zpos (xI (xI (xO (xO xH))))) (Zadd (Zmul x9 y8) (Zmul x8 y9)))))
+                                   (Zpos (xI (xO (xO (xI xH))))))
+                                (Zadd
+                                   (Zadd
+                                      (Zadd
+                                         (Zadd
+                                            (Zadd
+                                               (Zadd
+                                                  (Zadd (Zadd (Zadd (Zmul x8 y0) (Zmul (Zmul x7 y1) (Zpos (xO xH)))) (Zmul x6 y2))
+                                                     (Zmul (Zmul x5 y3) (Zpos (xO xH)))) (Zmul x4 y4))
+                                               (Zmul (Zmul x3 y5) (Zpos (xO xH)))) (Zmul x2 y6)) (Zmul (Zmul x1 y7) (Zpos (xO xH))))
+                                      (Zmul x0 y8)) (Zmul (Zmul (Zmul (Zpos (xI (xI (xO (xO xH))))) x9) y9) (Zpos (xO xH)))))
+                             (Zpos (xO (xI (xO (xI xH))))))
+                          (Zadd
+                             (Zadd
+                                (Zadd
+                                   (Zadd
+                                      (Zadd
+                                         (Zadd (Zadd (Zadd (Zadd (Zmul x9 y0) (Zmul x8 y1)) (Zmul x7 y2)) (Zmul x6 y3)) (Zmul x5 y4))
+                                         (Zmul x4 y5)) (Zmul x3 y6)) (Zmul x2 y7)) (Zmul x1 y8)) (Zmul x0 y9)))
+                       (Zpos (xI (xO (xO (xI xH)))))))
+                 (Z.land
+                    (Zadd (Zmul x0 y0)
+                       (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                          (Zadd
+                             (Zadd
+                                (Zadd
+                                   (Zadd
+                                      (Zadd
+                                         (Zadd
+                                            (Zadd (Zadd (Zmul (Zmul x9 y1) (Zpos (xO xH))) (Zmul x8 y2))
+                                               (Zmul (Zmul x7 y3) (Zpos (xO xH)))) (Zmul x6 y4)) (Zmul (Zmul x5 y5) (Zpos (xO xH))))
+                                      (Zmul x4 y6)) (Zmul (Zmul x3 y7) (Zpos (xO xH)))) (Zmul x2 y8))
+                             (Zmul (Zmul x1 y9) (Zpos (xO xH))))))
+                    (Zpos
+                       (xI
+                          (xI
+                             (xI
+                                (xI
+                                   (xI
+                                      (xI
+                                         (xI
+                                            (xI
+                                               (xI
+                                                  (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))))
+              (Zpos
+                 (xI
+                    (xI
+                       (xI
+                          (xI
+                             (xI
+                                (xI
+                                   (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))))
+           (@cons Z
+              (Zadd
+                 (Z.shiftr
+                    (Zadd
+                       (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                          (Z.shiftr
+                             (Zadd
+                                (Z.shiftr
+                                   (Zadd
+                                      (Z.shiftr
+                                         (Zadd
+                                            (Z.shiftr
+                                               (Zadd
+                                                  (Z.shiftr
+                                                     (Zadd
+                                                        (Z.shiftr
+                                                           (Zadd
+                                                              (Z.shiftr
+                                                                 (Zadd
+                                                                    (Z.shiftr
+                                                                       (Zadd
+                                                                          (Z.shiftr
+                                                                             (Zadd
+                                                                                (Z.shiftr
+                                                                                   (Zadd (Zmul x0 y0)
+                                                                                      (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                                         (Zadd
+                                                                                            (Zadd
+                                                                                               (Zadd
+                                                                                                  (Zadd
+                                                                                                     (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zmul
+                                                                                                       (Zmul x9 y1)
+                                                                                                       (Zpos (xO xH)))
+                                                                                                       (Zmul x8 y2))
+                                                                                                       (Zmul
+                                                                                                       (Zmul x7 y3)
+                                                                                                       (Zpos (xO xH))))
+                                                                                                       (Zmul x6 y4))
+                                                                                                       (Zmul
+                                                                                                       (Zmul x5 y5)
+                                                                                                       (Zpos (xO xH))))
+                                                                                                     (Zmul x4 y6))
+                                                                                                  (Zmul (Zmul x3 y7) (Zpos (xO xH))))
+                                                                                               (Zmul x2 y8))
+                                                                                            (Zmul (Zmul x1 y9) (Zpos (xO xH))))))
+                                                                                   (Zpos (xO (xI (xO (xI xH))))))
+                                                                                (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1))
+                                                                                   (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                                      (Zadd
+                                                                                         (Zadd
+                                                                                            (Zadd
+                                                                                               (Zadd
+                                                                                                  (Zadd
+                                                                                                     (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zmul x9 y2)
+                                                                                                       (Zmul x8 y3))
+                                                                                                       (Zmul x7 y4))
+                                                                                                     (Zmul x6 y5))
+                                                                                                  (Zmul x5 y6))
+                                                                                               (Zmul x4 y7))
+                                                                                            (Zmul x3 y8))
+                                                                                         (Zmul x2 y9)))))
+                                                                             (Zpos (xI (xO (xO (xI xH))))))
+                                                                          (Zadd
+                                                                             (Zadd
+                                                                                (Zadd (Zmul x2 y0)
+                                                                                   (Zmul (Zmul x1 y1) (Zpos (xO xH))))
+                                                                                (Zmul x0 y2))
+                                                                             (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                                (Zadd
+                                                                                   (Zadd
+                                                                                      (Zadd
+                                                                                         (Zadd
+                                                                                            (Zadd
+                                                                                               (Zadd
+                                                                                                  (Zmul (Zmul x9 y3) (Zpos (xO xH)))
+                                                                                                  (Zmul x8 y4))
+                                                                                               (Zmul (Zmul x7 y5) (Zpos (xO xH))))
+                                                                                            (Zmul x6 y6))
+                                                                                         (Zmul (Zmul x5 y7) (Zpos (xO xH))))
+                                                                                      (Zmul x4 y8))
+                                                                                   (Zmul (Zmul x3 y9) (Zpos (xO xH)))))))
+                                                                       (Zpos (xO (xI (xO (xI xH))))))
+                                                                    (Zadd
+                                                                       (Zadd (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) (Zmul x1 y2))
+                                                                          (Zmul x0 y3))
+                                                                       (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                          (Zadd
+                                                                             (Zadd
+                                                                                (Zadd
+                                                                                   (Zadd (Zadd (Zmul x9 y4) (Zmul x8 y5))
+                                                                                      (Zmul x7 y6)) (Zmul x6 y7))
+                                                                                (Zmul x5 y8)) (Zmul x4 y9)))))
+                                                                 (Zpos (xI (xO (xO (xI xH))))))
+                                                              (Zadd
+                                                                 (Zadd
+                                                                    (Zadd
+                                                                       (Zadd (Zadd (Zmul x4 y0) (Zmul (Zmul x3 y1) (Zpos (xO xH))))
+                                                                          (Zmul x2 y2)) (Zmul (Zmul x1 y3) (Zpos (xO xH))))
+                                                                    (Zmul x0 y4))
+                                                                 (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                    (Zadd
+                                                                       (Zadd
+                                                                          (Zadd
+                                                                             (Zadd (Zmul (Zmul x9 y5) (Zpos (xO xH))) (Zmul x8 y6))
+                                                                             (Zmul (Zmul x7 y7) (Zpos (xO xH))))
+                                                                          (Zmul x6 y8)) (Zmul (Zmul x5 y9) (Zpos (xO xH)))))))
+                                                           (Zpos (xO (xI (xO (xI xH))))))
+                                                        (Zadd
+                                                           (Zadd
+                                                              (Zadd
+                                                                 (Zadd (Zadd (Zadd (Zmul x5 y0) (Zmul x4 y1)) (Zmul x3 y2))
+                                                                    (Zmul x2 y3)) (Zmul x1 y4)) (Zmul x0 y5))
+                                                           (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                              (Zadd (Zadd (Zadd (Zmul x9 y6) (Zmul x8 y7)) (Zmul x7 y8))
+                                                                 (Zmul x6 y9))))) (Zpos (xI (xO (xO (xI xH))))))
+                                                  (Zadd
+                                                     (Zadd
+                                                        (Zadd
+                                                           (Zadd
+                                                              (Zadd
+                                                                 (Zadd (Zadd (Zmul x6 y0) (Zmul (Zmul x5 y1) (Zpos (xO xH))))
+                                                                    (Zmul x4 y2)) (Zmul (Zmul x3 y3) (Zpos (xO xH))))
+                                                              (Zmul x2 y4)) (Zmul (Zmul x1 y5) (Zpos (xO xH))))
+                                                        (Zmul x0 y6))
+                                                     (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                        (Zadd (Zadd (Zmul (Zmul x9 y7) (Zpos (xO xH))) (Zmul x8 y8))
+                                                           (Zmul (Zmul x7 y9) (Zpos (xO xH))))))) (Zpos (xO (xI (xO (xI xH))))))
+                                            (Zadd
+                                               (Zadd
+                                                  (Zadd
+                                                     (Zadd
+                                                        (Zadd
+                                                           (Zadd (Zadd (Zadd (Zmul x7 y0) (Zmul x6 y1)) (Zmul x5 y2)) (Zmul x4 y3))
+                                                           (Zmul x3 y4)) (Zmul x2 y5)) (Zmul x1 y6)) (Zmul x0 y7))
+                                               (Zmul (Zpos (xI (xI (xO (xO xH))))) (Zadd (Zmul x9 y8) (Zmul x8 y9)))))
+                                         (Zpos (xI (xO (xO (xI xH))))))
+                                      (Zadd
+                                         (Zadd
+                                            (Zadd
+                                               (Zadd
+                                                  (Zadd
+                                                     (Zadd
+                                                        (Zadd
+                                                           (Zadd (Zadd (Zmul x8 y0) (Zmul (Zmul x7 y1) (Zpos (xO xH)))) (Zmul x6 y2))
+                                                           (Zmul (Zmul x5 y3) (Zpos (xO xH)))) (Zmul x4 y4))
+                                                     (Zmul (Zmul x3 y5) (Zpos (xO xH)))) (Zmul x2 y6))
+                                               (Zmul (Zmul x1 y7) (Zpos (xO xH)))) (Zmul x0 y8))
+                                         (Zmul (Zmul (Zmul (Zpos (xI (xI (xO (xO xH))))) x9) y9) (Zpos (xO xH)))))
+                                   (Zpos (xO (xI (xO (xI xH))))))
+                                (Zadd
+                                   (Zadd
+                                      (Zadd
+                                         (Zadd
+                                            (Zadd
+                                               (Zadd (Zadd (Zadd (Zadd (Zmul x9 y0) (Zmul x8 y1)) (Zmul x7 y2)) (Zmul x6 y3))
+                                                  (Zmul x5 y4)) (Zmul x4 y5)) (Zmul x3 y6)) (Zmul x2 y7))
+                                      (Zmul x1 y8)) (Zmul x0 y9))) (Zpos (xI (xO (xO (xI xH)))))))
+                       (Z.land
+                          (Zadd (Zmul x0 y0)
+                             (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                (Zadd
+                                   (Zadd
+                                      (Zadd
+                                         (Zadd
+                                            (Zadd
+                                               (Zadd
+                                                  (Zadd (Zadd (Zmul (Zmul x9 y1) (Zpos (xO xH))) (Zmul x8 y2))
+                                                     (Zmul (Zmul x7 y3) (Zpos (xO xH)))) (Zmul x6 y4))
+                                               (Zmul (Zmul x5 y5) (Zpos (xO xH)))) (Zmul x4 y6)) (Zmul (Zmul x3 y7) (Zpos (xO xH))))
+                                      (Zmul x2 y8)) (Zmul (Zmul x1 y9) (Zpos (xO xH))))))
+                          (Zpos
+                             (xI
+                                (xI
+                                   (xI
+                                      (xI
+                                         (xI
+                                            (xI
+                                               (xI
+                                                  (xI
+                                                     (xI
+                                                        (xI
+                                                           (xI
+                                                              (xI
+                                                                 (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))))
+                    (Zpos (xO (xI (xO (xI xH))))))
+                 (Z.land
+                    (Zadd
+                       (Z.shiftr
+                          (Zadd (Zmul x0 y0)
+                             (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                (Zadd
+                                   (Zadd
+                                      (Zadd
+                                         (Zadd
+                                            (Zadd
+                                               (Zadd
+                                                  (Zadd (Zadd (Zmul (Zmul x9 y1) (Zpos (xO xH))) (Zmul x8 y2))
+                                                     (Zmul (Zmul x7 y3) (Zpos (xO xH)))) (Zmul x6 y4))
+                                               (Zmul (Zmul x5 y5) (Zpos (xO xH)))) (Zmul x4 y6)) (Zmul (Zmul x3 y7) (Zpos (xO xH))))
+                                      (Zmul x2 y8)) (Zmul (Zmul x1 y9) (Zpos (xO xH)))))) (Zpos (xO (xI (xO (xI xH))))))
+                       (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1))
+                          (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                             (Zadd
+                                (Zadd
+                                   (Zadd
+                                      (Zadd (Zadd (Zadd (Zadd (Zmul x9 y2) (Zmul x8 y3)) (Zmul x7 y4)) (Zmul x6 y5)) (Zmul x5 y6))
+                                      (Zmul x4 y7)) (Zmul x3 y8)) (Zmul x2 y9)))))
+                    (Zpos
+                       (xI
+                          (xI
+                             (xI
+                                (xI
+                                   (xI
+                                      (xI
+                                         (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))))
+              (@cons Z
+                 (Z.land
+                    (Zadd
+                       (Z.shiftr
+                          (Zadd
+                             (Z.shiftr
+                                (Zadd (Zmul x0 y0)
+                                   (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                      (Zadd
+                                         (Zadd
+                                            (Zadd
+                                               (Zadd
+                                                  (Zadd
+                                                     (Zadd
+                                                        (Zadd (Zadd (Zmul (Zmul x9 y1) (Zpos (xO xH))) (Zmul x8 y2))
+                                                           (Zmul (Zmul x7 y3) (Zpos (xO xH)))) (Zmul x6 y4))
+                                                     (Zmul (Zmul x5 y5) (Zpos (xO xH)))) (Zmul x4 y6))
+                                               (Zmul (Zmul x3 y7) (Zpos (xO xH)))) (Zmul x2 y8)) (Zmul (Zmul x1 y9) (Zpos (xO xH))))))
+                                (Zpos (xO (xI (xO (xI xH))))))
+                             (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1))
+                                (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                   (Zadd
+                                      (Zadd
+                                         (Zadd
+                                            (Zadd (Zadd (Zadd (Zadd (Zmul x9 y2) (Zmul x8 y3)) (Zmul x7 y4)) (Zmul x6 y5))
+                                               (Zmul x5 y6)) (Zmul x4 y7)) (Zmul x3 y8)) (Zmul x2 y9)))))
+                          (Zpos (xI (xO (xO (xI xH))))))
+                       (Zadd (Zadd (Zadd (Zmul x2 y0) (Zmul (Zmul x1 y1) (Zpos (xO xH)))) (Zmul x0 y2))
+                          (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                             (Zadd
+                                (Zadd
+                                   (Zadd
+                                      (Zadd
+                                         (Zadd (Zadd (Zmul (Zmul x9 y3) (Zpos (xO xH))) (Zmul x8 y4))
+                                            (Zmul (Zmul x7 y5) (Zpos (xO xH)))) (Zmul x6 y6)) (Zmul (Zmul x5 y7) (Zpos (xO xH))))
+                                   (Zmul x4 y8)) (Zmul (Zmul x3 y9) (Zpos (xO xH)))))))
+                    (Zpos
+                       (xI
+                          (xI
+                             (xI
+                                (xI
+                                   (xI
+                                      (xI
+                                         (xI
+                                            (xI
+                                               (xI
+                                                  (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))))
+                 (@cons Z
+                    (Z.land
+                       (Zadd
+                          (Z.shiftr
+                             (Zadd
+                                (Z.shiftr
+                                   (Zadd
+                                      (Z.shiftr
+                                         (Zadd (Zmul x0 y0)
+                                            (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                               (Zadd
+                                                  (Zadd
+                                                     (Zadd
+                                                        (Zadd
+                                                           (Zadd
+                                                              (Zadd
+                                                                 (Zadd (Zadd (Zmul (Zmul x9 y1) (Zpos (xO xH))) (Zmul x8 y2))
+                                                                    (Zmul (Zmul x7 y3) (Zpos (xO xH))))
+                                                                 (Zmul x6 y4)) (Zmul (Zmul x5 y5) (Zpos (xO xH))))
+                                                           (Zmul x4 y6)) (Zmul (Zmul x3 y7) (Zpos (xO xH))))
+                                                     (Zmul x2 y8)) (Zmul (Zmul x1 y9) (Zpos (xO xH))))))
+                                         (Zpos (xO (xI (xO (xI xH))))))
+                                      (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1))
+                                         (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                            (Zadd
+                                               (Zadd
+                                                  (Zadd
+                                                     (Zadd (Zadd (Zadd (Zadd (Zmul x9 y2) (Zmul x8 y3)) (Zmul x7 y4)) (Zmul x6 y5))
+                                                        (Zmul x5 y6)) (Zmul x4 y7)) (Zmul x3 y8)) (Zmul x2 y9)))))
+                                   (Zpos (xI (xO (xO (xI xH))))))
+                                (Zadd (Zadd (Zadd (Zmul x2 y0) (Zmul (Zmul x1 y1) (Zpos (xO xH)))) (Zmul x0 y2))
+                                   (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                      (Zadd
+                                         (Zadd
+                                            (Zadd
+                                               (Zadd
+                                                  (Zadd (Zadd (Zmul (Zmul x9 y3) (Zpos (xO xH))) (Zmul x8 y4))
+                                                     (Zmul (Zmul x7 y5) (Zpos (xO xH)))) (Zmul x6 y6))
+                                               (Zmul (Zmul x5 y7) (Zpos (xO xH)))) (Zmul x4 y8)) (Zmul (Zmul x3 y9) (Zpos (xO xH)))))))
+                             (Zpos (xO (xI (xO (xI xH))))))
+                          (Zadd (Zadd (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) (Zmul x1 y2)) (Zmul x0 y3))
+                             (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                (Zadd (Zadd (Zadd (Zadd (Zadd (Zmul x9 y4) (Zmul x8 y5)) (Zmul x7 y6)) (Zmul x6 y7)) (Zmul x5 y8))
+                                   (Zmul x4 y9)))))
+                       (Zpos
+                          (xI
+                             (xI
+                                (xI
+                                   (xI
+                                      (xI
+                                         (xI
+                                            (xI
+                                               (xI
+                                                  (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))
+                    (@cons Z
+                       (Z.land
+                          (Zadd
+                             (Z.shiftr
+                                (Zadd
+                                   (Z.shiftr
+                                      (Zadd
+                                         (Z.shiftr
+                                            (Zadd
+                                               (Z.shiftr
+                                                  (Zadd (Zmul x0 y0)
+                                                     (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                        (Zadd
+                                                           (Zadd
+                                                              (Zadd
+                                                                 (Zadd
+                                                                    (Zadd
+                                                                       (Zadd
+                                                                          (Zadd
+                                                                             (Zadd (Zmul (Zmul x9 y1) (Zpos (xO xH))) (Zmul x8 y2))
+                                                                             (Zmul (Zmul x7 y3) (Zpos (xO xH))))
+                                                                          (Zmul x6 y4)) (Zmul (Zmul x5 y5) (Zpos (xO xH))))
+                                                                    (Zmul x4 y6)) (Zmul (Zmul x3 y7) (Zpos (xO xH))))
+                                                              (Zmul x2 y8)) (Zmul (Zmul x1 y9) (Zpos (xO xH))))))
+                                                  (Zpos (xO (xI (xO (xI xH))))))
+                                               (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1))
+                                                  (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                     (Zadd
+                                                        (Zadd
+                                                           (Zadd
+                                                              (Zadd
+                                                                 (Zadd (Zadd (Zadd (Zmul x9 y2) (Zmul x8 y3)) (Zmul x7 y4))
+                                                                    (Zmul x6 y5)) (Zmul x5 y6)) (Zmul x4 y7))
+                                                           (Zmul x3 y8)) (Zmul x2 y9))))) (Zpos (xI (xO (xO (xI xH))))))
+                                         (Zadd (Zadd (Zadd (Zmul x2 y0) (Zmul (Zmul x1 y1) (Zpos (xO xH)))) (Zmul x0 y2))
+                                            (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                               (Zadd
+                                                  (Zadd
+                                                     (Zadd
+                                                        (Zadd
+                                                           (Zadd (Zadd (Zmul (Zmul x9 y3) (Zpos (xO xH))) (Zmul x8 y4))
+                                                              (Zmul (Zmul x7 y5) (Zpos (xO xH)))) (Zmul x6 y6))
+                                                        (Zmul (Zmul x5 y7) (Zpos (xO xH)))) (Zmul x4 y8))
+                                                  (Zmul (Zmul x3 y9) (Zpos (xO xH))))))) (Zpos (xO (xI (xO (xI xH))))))
+                                   (Zadd (Zadd (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) (Zmul x1 y2)) (Zmul x0 y3))
+                                      (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                         (Zadd
+                                            (Zadd (Zadd (Zadd (Zadd (Zmul x9 y4) (Zmul x8 y5)) (Zmul x7 y6)) (Zmul x6 y7))
+                                               (Zmul x5 y8)) (Zmul x4 y9))))) (Zpos (xI (xO (xO (xI xH))))))
+                             (Zadd
+                                (Zadd
+                                   (Zadd (Zadd (Zadd (Zmul x4 y0) (Zmul (Zmul x3 y1) (Zpos (xO xH)))) (Zmul x2 y2))
+                                      (Zmul (Zmul x1 y3) (Zpos (xO xH)))) (Zmul x0 y4))
+                                (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                   (Zadd
+                                      (Zadd
+                                         (Zadd (Zadd (Zmul (Zmul x9 y5) (Zpos (xO xH))) (Zmul x8 y6))
+                                            (Zmul (Zmul x7 y7) (Zpos (xO xH)))) (Zmul x6 y8)) (Zmul (Zmul x5 y9) (Zpos (xO xH)))))))
+                          (Zpos
+                             (xI
+                                (xI
+                                   (xI
+                                      (xI
+                                         (xI
+                                            (xI
+                                               (xI
+                                                  (xI
+                                                     (xI
+                                                        (xI
+                                                           (xI
+                                                              (xI
+                                                                 (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))))
+                       (@cons Z
+                          (Z.land
+                             (Zadd
+                                (Z.shiftr
+                                   (Zadd
+                                      (Z.shiftr
+                                         (Zadd
+                                            (Z.shiftr
+                                               (Zadd
+                                                  (Z.shiftr
+                                                     (Zadd
+                                                        (Z.shiftr
+                                                           (Zadd (Zmul x0 y0)
+                                                              (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                 (Zadd
+                                                                    (Zadd
+                                                                       (Zadd
+                                                                          (Zadd
+                                                                             (Zadd
+                                                                                (Zadd
+                                                                                   (Zadd
+                                                                                      (Zadd (Zmul (Zmul x9 y1) (Zpos (xO xH)))
+                                                                                         (Zmul x8 y2))
+                                                                                      (Zmul (Zmul x7 y3) (Zpos (xO xH))))
+                                                                                   (Zmul x6 y4)) (Zmul (Zmul x5 y5) (Zpos (xO xH))))
+                                                                             (Zmul x4 y6)) (Zmul (Zmul x3 y7) (Zpos (xO xH))))
+                                                                       (Zmul x2 y8)) (Zmul (Zmul x1 y9) (Zpos (xO xH))))))
+                                                           (Zpos (xO (xI (xO (xI xH))))))
+                                                        (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1))
+                                                           (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                              (Zadd
+                                                                 (Zadd
+                                                                    (Zadd
+                                                                       (Zadd
+                                                                          (Zadd (Zadd (Zadd (Zmul x9 y2) (Zmul x8 y3)) (Zmul x7 y4))
+                                                                             (Zmul x6 y5)) (Zmul x5 y6))
+                                                                       (Zmul x4 y7)) (Zmul x3 y8)) (Zmul x2 y9)))))
+                                                     (Zpos (xI (xO (xO (xI xH))))))
+                                                  (Zadd (Zadd (Zadd (Zmul x2 y0) (Zmul (Zmul x1 y1) (Zpos (xO xH)))) (Zmul x0 y2))
+                                                     (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                        (Zadd
+                                                           (Zadd
+                                                              (Zadd
+                                                                 (Zadd
+                                                                    (Zadd (Zadd (Zmul (Zmul x9 y3) (Zpos (xO xH))) (Zmul x8 y4))
+                                                                       (Zmul (Zmul x7 y5) (Zpos (xO xH))))
+                                                                    (Zmul x6 y6)) (Zmul (Zmul x5 y7) (Zpos (xO xH))))
+                                                              (Zmul x4 y8)) (Zmul (Zmul x3 y9) (Zpos (xO xH)))))))
+                                               (Zpos (xO (xI (xO (xI xH))))))
+                                            (Zadd (Zadd (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) (Zmul x1 y2)) (Zmul x0 y3))
+                                               (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                  (Zadd
+                                                     (Zadd (Zadd (Zadd (Zadd (Zmul x9 y4) (Zmul x8 y5)) (Zmul x7 y6)) (Zmul x6 y7))
+                                                        (Zmul x5 y8)) (Zmul x4 y9))))) (Zpos (xI (xO (xO (xI xH))))))
+                                      (Zadd
+                                         (Zadd
+                                            (Zadd (Zadd (Zadd (Zmul x4 y0) (Zmul (Zmul x3 y1) (Zpos (xO xH)))) (Zmul x2 y2))
+                                               (Zmul (Zmul x1 y3) (Zpos (xO xH)))) (Zmul x0 y4))
+                                         (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                            (Zadd
+                                               (Zadd
+                                                  (Zadd (Zadd (Zmul (Zmul x9 y5) (Zpos (xO xH))) (Zmul x8 y6))
+                                                     (Zmul (Zmul x7 y7) (Zpos (xO xH)))) (Zmul x6 y8))
+                                               (Zmul (Zmul x5 y9) (Zpos (xO xH))))))) (Zpos (xO (xI (xO (xI xH))))))
+                                (Zadd
+                                   (Zadd
+                                      (Zadd (Zadd (Zadd (Zadd (Zmul x5 y0) (Zmul x4 y1)) (Zmul x3 y2)) (Zmul x2 y3)) (Zmul x1 y4))
+                                      (Zmul x0 y5))
+                                   (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                      (Zadd (Zadd (Zadd (Zmul x9 y6) (Zmul x8 y7)) (Zmul x7 y8)) (Zmul x6 y9)))))
+                             (Zpos
+                                (xI
+                                   (xI
+                                      (xI
+                                         (xI
+                                            (xI
+                                               (xI
+                                                  (xI
+                                                     (xI
+                                                        (xI
+                                                           (xI
+                                                              (xI
+                                                                 (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))
+                          (@cons Z
+                             (Z.land
+                                (Zadd
+                                   (Z.shiftr
+                                      (Zadd
+                                         (Z.shiftr
+                                            (Zadd
+                                               (Z.shiftr
+                                                  (Zadd
+                                                     (Z.shiftr
+                                                        (Zadd
+                                                           (Z.shiftr
+                                                              (Zadd
+                                                                 (Z.shiftr
+                                                                    (Zadd (Zmul x0 y0)
+                                                                       (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                          (Zadd
+                                                                             (Zadd
+                                                                                (Zadd
+                                                                                   (Zadd
+                                                                                      (Zadd
+                                                                                         (Zadd
+                                                                                            (Zadd
+                                                                                               (Zadd
+                                                                                                  (Zmul (Zmul x9 y1) (Zpos (xO xH)))
+                                                                                                  (Zmul x8 y2))
+                                                                                               (Zmul (Zmul x7 y3) (Zpos (xO xH))))
+                                                                                            (Zmul x6 y4))
+                                                                                         (Zmul (Zmul x5 y5) (Zpos (xO xH))))
+                                                                                      (Zmul x4 y6))
+                                                                                   (Zmul (Zmul x3 y7) (Zpos (xO xH))))
+                                                                                (Zmul x2 y8)) (Zmul (Zmul x1 y9) (Zpos (xO xH))))))
+                                                                    (Zpos (xO (xI (xO (xI xH))))))
+                                                                 (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1))
+                                                                    (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                       (Zadd
+                                                                          (Zadd
+                                                                             (Zadd
+                                                                                (Zadd
+                                                                                   (Zadd
+                                                                                      (Zadd (Zadd (Zmul x9 y2) (Zmul x8 y3))
+                                                                                         (Zmul x7 y4)) (Zmul x6 y5))
+                                                                                   (Zmul x5 y6)) (Zmul x4 y7))
+                                                                             (Zmul x3 y8)) (Zmul x2 y9)))))
+                                                              (Zpos (xI (xO (xO (xI xH))))))
+                                                           (Zadd
+                                                              (Zadd (Zadd (Zmul x2 y0) (Zmul (Zmul x1 y1) (Zpos (xO xH))))
+                                                                 (Zmul x0 y2))
+                                                              (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                 (Zadd
+                                                                    (Zadd
+                                                                       (Zadd
+                                                                          (Zadd
+                                                                             (Zadd
+                                                                                (Zadd (Zmul (Zmul x9 y3) (Zpos (xO xH)))
+                                                                                   (Zmul x8 y4)) (Zmul (Zmul x7 y5) (Zpos (xO xH))))
+                                                                             (Zmul x6 y6)) (Zmul (Zmul x5 y7) (Zpos (xO xH))))
+                                                                       (Zmul x4 y8)) (Zmul (Zmul x3 y9) (Zpos (xO xH)))))))
+                                                        (Zpos (xO (xI (xO (xI xH))))))
+                                                     (Zadd (Zadd (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) (Zmul x1 y2)) (Zmul x0 y3))
+                                                        (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                           (Zadd
+                                                              (Zadd
+                                                                 (Zadd (Zadd (Zadd (Zmul x9 y4) (Zmul x8 y5)) (Zmul x7 y6))
+                                                                    (Zmul x6 y7)) (Zmul x5 y8)) (Zmul x4 y9)))))
+                                                  (Zpos (xI (xO (xO (xI xH))))))
+                                               (Zadd
+                                                  (Zadd
+                                                     (Zadd
+                                                        (Zadd (Zadd (Zmul x4 y0) (Zmul (Zmul x3 y1) (Zpos (xO xH)))) (Zmul x2 y2))
+                                                        (Zmul (Zmul x1 y3) (Zpos (xO xH)))) (Zmul x0 y4))
+                                                  (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                     (Zadd
+                                                        (Zadd
+                                                           (Zadd (Zadd (Zmul (Zmul x9 y5) (Zpos (xO xH))) (Zmul x8 y6))
+                                                              (Zmul (Zmul x7 y7) (Zpos (xO xH)))) (Zmul x6 y8))
+                                                        (Zmul (Zmul x5 y9) (Zpos (xO xH))))))) (Zpos (xO (xI (xO (xI xH))))))
+                                         (Zadd
+                                            (Zadd
+                                               (Zadd (Zadd (Zadd (Zadd (Zmul x5 y0) (Zmul x4 y1)) (Zmul x3 y2)) (Zmul x2 y3))
+                                                  (Zmul x1 y4)) (Zmul x0 y5))
+                                            (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                               (Zadd (Zadd (Zadd (Zmul x9 y6) (Zmul x8 y7)) (Zmul x7 y8)) (Zmul x6 y9)))))
+                                      (Zpos (xI (xO (xO (xI xH))))))
+                                   (Zadd
+                                      (Zadd
+                                         (Zadd
+                                            (Zadd
+                                               (Zadd (Zadd (Zadd (Zmul x6 y0) (Zmul (Zmul x5 y1) (Zpos (xO xH)))) (Zmul x4 y2))
+                                                  (Zmul (Zmul x3 y3) (Zpos (xO xH)))) (Zmul x2 y4))
+                                            (Zmul (Zmul x1 y5) (Zpos (xO xH)))) (Zmul x0 y6))
+                                      (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                         (Zadd (Zadd (Zmul (Zmul x9 y7) (Zpos (xO xH))) (Zmul x8 y8))
+                                            (Zmul (Zmul x7 y9) (Zpos (xO xH)))))))
+                                (Zpos
+                                   (xI
+                                      (xI
+                                         (xI
+                                            (xI
+                                               (xI
+                                                  (xI
+                                                     (xI
+                                                        (xI
+                                                           (xI
+                                                              (xI
+                                                                 (xI
+                                                                    (xI
+                                                                       (xI
+                                                                          (xI
+                                                                             (xI
+                                                                                (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))))
+                             (@cons Z
+                                (Z.land
+                                   (Zadd
+                                      (Z.shiftr
+                                         (Zadd
+                                            (Z.shiftr
+                                               (Zadd
+                                                  (Z.shiftr
+                                                     (Zadd
+                                                        (Z.shiftr
+                                                           (Zadd
+                                                              (Z.shiftr
+                                                                 (Zadd
+                                                                    (Z.shiftr
+                                                                       (Zadd
+                                                                          (Z.shiftr
+                                                                             (Zadd (Zmul x0 y0)
+                                                                                (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                                   (Zadd
+                                                                                      (Zadd
+                                                                                         (Zadd
+                                                                                            (Zadd
+                                                                                               (Zadd
+                                                                                                  (Zadd
+                                                                                                     (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zmul
+                                                                                                       (Zmul x9 y1)
+                                                                                                       (Zpos (xO xH)))
+                                                                                                       (Zmul x8 y2))
+                                                                                                       (Zmul
+                                                                                                       (Zmul x7 y3)
+                                                                                                       (Zpos (xO xH))))
+                                                                                                     (Zmul x6 y4))
+                                                                                                  (Zmul (Zmul x5 y5) (Zpos (xO xH))))
+                                                                                               (Zmul x4 y6))
+                                                                                            (Zmul (Zmul x3 y7) (Zpos (xO xH))))
+                                                                                         (Zmul x2 y8))
+                                                                                      (Zmul (Zmul x1 y9) (Zpos (xO xH))))))
+                                                                             (Zpos (xO (xI (xO (xI xH))))))
+                                                                          (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1))
+                                                                             (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                                (Zadd
+                                                                                   (Zadd
+                                                                                      (Zadd
+                                                                                         (Zadd
+                                                                                            (Zadd
+                                                                                               (Zadd
+                                                                                                  (Zadd (Zmul x9 y2) (Zmul x8 y3))
+                                                                                                  (Zmul x7 y4))
+                                                                                               (Zmul x6 y5))
+                                                                                            (Zmul x5 y6))
+                                                                                         (Zmul x4 y7)) (Zmul x3 y8))
+                                                                                   (Zmul x2 y9))))) (Zpos (xI (xO (xO (xI xH))))))
+                                                                    (Zadd
+                                                                       (Zadd (Zadd (Zmul x2 y0) (Zmul (Zmul x1 y1) (Zpos (xO xH))))
+                                                                          (Zmul x0 y2))
+                                                                       (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                          (Zadd
+                                                                             (Zadd
+                                                                                (Zadd
+                                                                                   (Zadd
+                                                                                      (Zadd
+                                                                                         (Zadd (Zmul (Zmul x9 y3) (Zpos (xO xH)))
+                                                                                            (Zmul x8 y4))
+                                                                                         (Zmul (Zmul x7 y5) (Zpos (xO xH))))
+                                                                                      (Zmul x6 y6))
+                                                                                   (Zmul (Zmul x5 y7) (Zpos (xO xH))))
+                                                                                (Zmul x4 y8)) (Zmul (Zmul x3 y9) (Zpos (xO xH)))))))
+                                                                 (Zpos (xO (xI (xO (xI xH))))))
+                                                              (Zadd
+                                                                 (Zadd (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) (Zmul x1 y2))
+                                                                    (Zmul x0 y3))
+                                                                 (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                    (Zadd
+                                                                       (Zadd
+                                                                          (Zadd (Zadd (Zadd (Zmul x9 y4) (Zmul x8 y5)) (Zmul x7 y6))
+                                                                             (Zmul x6 y7)) (Zmul x5 y8))
+                                                                       (Zmul x4 y9))))) (Zpos (xI (xO (xO (xI xH))))))
+                                                        (Zadd
+                                                           (Zadd
+                                                              (Zadd
+                                                                 (Zadd (Zadd (Zmul x4 y0) (Zmul (Zmul x3 y1) (Zpos (xO xH))))
+                                                                    (Zmul x2 y2)) (Zmul (Zmul x1 y3) (Zpos (xO xH))))
+                                                              (Zmul x0 y4))
+                                                           (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                              (Zadd
+                                                                 (Zadd
+                                                                    (Zadd (Zadd (Zmul (Zmul x9 y5) (Zpos (xO xH))) (Zmul x8 y6))
+                                                                       (Zmul (Zmul x7 y7) (Zpos (xO xH))))
+                                                                    (Zmul x6 y8)) (Zmul (Zmul x5 y9) (Zpos (xO xH)))))))
+                                                     (Zpos (xO (xI (xO (xI xH))))))
+                                                  (Zadd
+                                                     (Zadd
+                                                        (Zadd
+                                                           (Zadd (Zadd (Zadd (Zmul x5 y0) (Zmul x4 y1)) (Zmul x3 y2)) (Zmul x2 y3))
+                                                           (Zmul x1 y4)) (Zmul x0 y5))
+                                                     (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                        (Zadd (Zadd (Zadd (Zmul x9 y6) (Zmul x8 y7)) (Zmul x7 y8)) (Zmul x6 y9)))))
+                                               (Zpos (xI (xO (xO (xI xH))))))
+                                            (Zadd
+                                               (Zadd
+                                                  (Zadd
+                                                     (Zadd
+                                                        (Zadd
+                                                           (Zadd (Zadd (Zmul x6 y0) (Zmul (Zmul x5 y1) (Zpos (xO xH)))) (Zmul x4 y2))
+                                                           (Zmul (Zmul x3 y3) (Zpos (xO xH)))) (Zmul x2 y4))
+                                                     (Zmul (Zmul x1 y5) (Zpos (xO xH)))) (Zmul x0 y6))
+                                               (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                  (Zadd (Zadd (Zmul (Zmul x9 y7) (Zpos (xO xH))) (Zmul x8 y8))
+                                                     (Zmul (Zmul x7 y9) (Zpos (xO xH))))))) (Zpos (xO (xI (xO (xI xH))))))
+                                      (Zadd
+                                         (Zadd
+                                            (Zadd
+                                               (Zadd
+                                                  (Zadd (Zadd (Zadd (Zadd (Zmul x7 y0) (Zmul x6 y1)) (Zmul x5 y2)) (Zmul x4 y3))
+                                                     (Zmul x3 y4)) (Zmul x2 y5)) (Zmul x1 y6)) (Zmul x0 y7))
+                                         (Zmul (Zpos (xI (xI (xO (xO xH))))) (Zadd (Zmul x9 y8) (Zmul x8 y9)))))
+                                   (Zpos
+                                      (xI
+                                         (xI
+                                            (xI
+                                               (xI
+                                                  (xI
+                                                     (xI
+                                                        (xI
+                                                           (xI
+                                                              (xI
+                                                                 (xI
+                                                                    (xI
+                                                                       (xI
+                                                                          (xI
+                                                                             (xI
+                                                                                (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))
+                                (@cons Z
+                                   (Z.land
+                                      (Zadd
+                                         (Z.shiftr
+                                            (Zadd
+                                               (Z.shiftr
+                                                  (Zadd
+                                                     (Z.shiftr
+                                                        (Zadd
+                                                           (Z.shiftr
+                                                              (Zadd
+                                                                 (Z.shiftr
+                                                                    (Zadd
+                                                                       (Z.shiftr
+                                                                          (Zadd
+                                                                             (Z.shiftr
+                                                                                (Zadd
+                                                                                   (Z.shiftr
+                                                                                      (Zadd (Zmul x0 y0)
+                                                                                         (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                                            (Zadd
+                                                                                               (Zadd
+                                                                                                  (Zadd
+                                                                                                     (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zmul
+                                                                                                       (Zmul x9 y1)
+                                                                                                       (Zpos (xO xH)))
+                                                                                                       (Zmul x8 y2))
+                                                                                                       (Zmul
+                                                                                                       (Zmul x7 y3)
+                                                                                                       (Zpos (xO xH))))
+                                                                                                       (Zmul x6 y4))
+                                                                                                       (Zmul
+                                                                                                       (Zmul x5 y5)
+                                                                                                       (Zpos (xO xH))))
+                                                                                                       (Zmul x4 y6))
+                                                                                                     (Zmul
+                                                                                                       (Zmul x3 y7)
+                                                                                                       (Zpos (xO xH))))
+                                                                                                  (Zmul x2 y8))
+                                                                                               (Zmul (Zmul x1 y9) (Zpos (xO xH))))))
+                                                                                      (Zpos (xO (xI (xO (xI xH))))))
+                                                                                   (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1))
+                                                                                      (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                                         (Zadd
+                                                                                            (Zadd
+                                                                                               (Zadd
+                                                                                                  (Zadd
+                                                                                                     (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zmul x9 y2)
+                                                                                                       (Zmul x8 y3))
+                                                                                                       (Zmul x7 y4))
+                                                                                                       (Zmul x6 y5))
+                                                                                                     (Zmul x5 y6))
+                                                                                                  (Zmul x4 y7))
+                                                                                               (Zmul x3 y8))
+                                                                                            (Zmul x2 y9)))))
+                                                                                (Zpos (xI (xO (xO (xI xH))))))
+                                                                             (Zadd
+                                                                                (Zadd
+                                                                                   (Zadd (Zmul x2 y0)
+                                                                                      (Zmul (Zmul x1 y1) (Zpos (xO xH))))
+                                                                                   (Zmul x0 y2))
+                                                                                (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                                   (Zadd
+                                                                                      (Zadd
+                                                                                         (Zadd
+                                                                                            (Zadd
+                                                                                               (Zadd
+                                                                                                  (Zadd
+                                                                                                     (Zmul
+                                                                                                       (Zmul x9 y3)
+                                                                                                       (Zpos (xO xH)))
+                                                                                                     (Zmul x8 y4))
+                                                                                                  (Zmul (Zmul x7 y5) (Zpos (xO xH))))
+                                                                                               (Zmul x6 y6))
+                                                                                            (Zmul (Zmul x5 y7) (Zpos (xO xH))))
+                                                                                         (Zmul x4 y8))
+                                                                                      (Zmul (Zmul x3 y9) (Zpos (xO xH)))))))
+                                                                          (Zpos (xO (xI (xO (xI xH))))))
+                                                                       (Zadd
+                                                                          (Zadd (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) (Zmul x1 y2))
+                                                                             (Zmul x0 y3))
+                                                                          (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                             (Zadd
+                                                                                (Zadd
+                                                                                   (Zadd
+                                                                                      (Zadd (Zadd (Zmul x9 y4) (Zmul x8 y5))
+                                                                                         (Zmul x7 y6)) (Zmul x6 y7))
+                                                                                   (Zmul x5 y8)) (Zmul x4 y9)))))
+                                                                    (Zpos (xI (xO (xO (xI xH))))))
+                                                                 (Zadd
+                                                                    (Zadd
+                                                                       (Zadd
+                                                                          (Zadd
+                                                                             (Zadd (Zmul x4 y0) (Zmul (Zmul x3 y1) (Zpos (xO xH))))
+                                                                             (Zmul x2 y2)) (Zmul (Zmul x1 y3) (Zpos (xO xH))))
+                                                                       (Zmul x0 y4))
+                                                                    (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                       (Zadd
+                                                                          (Zadd
+                                                                             (Zadd
+                                                                                (Zadd (Zmul (Zmul x9 y5) (Zpos (xO xH)))
+                                                                                   (Zmul x8 y6)) (Zmul (Zmul x7 y7) (Zpos (xO xH))))
+                                                                             (Zmul x6 y8)) (Zmul (Zmul x5 y9) (Zpos (xO xH)))))))
+                                                              (Zpos (xO (xI (xO (xI xH))))))
+                                                           (Zadd
+                                                              (Zadd
+                                                                 (Zadd
+                                                                    (Zadd (Zadd (Zadd (Zmul x5 y0) (Zmul x4 y1)) (Zmul x3 y2))
+                                                                       (Zmul x2 y3)) (Zmul x1 y4)) (Zmul x0 y5))
+                                                              (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                 (Zadd (Zadd (Zadd (Zmul x9 y6) (Zmul x8 y7)) (Zmul x7 y8))
+                                                                    (Zmul x6 y9))))) (Zpos (xI (xO (xO (xI xH))))))
+                                                     (Zadd
+                                                        (Zadd
+                                                           (Zadd
+                                                              (Zadd
+                                                                 (Zadd
+                                                                    (Zadd (Zadd (Zmul x6 y0) (Zmul (Zmul x5 y1) (Zpos (xO xH))))
+                                                                       (Zmul x4 y2)) (Zmul (Zmul x3 y3) (Zpos (xO xH))))
+                                                                 (Zmul x2 y4)) (Zmul (Zmul x1 y5) (Zpos (xO xH))))
+                                                           (Zmul x0 y6))
+                                                        (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                           (Zadd (Zadd (Zmul (Zmul x9 y7) (Zpos (xO xH))) (Zmul x8 y8))
+                                                              (Zmul (Zmul x7 y9) (Zpos (xO xH))))))) (Zpos (xO (xI (xO (xI xH))))))
+                                               (Zadd
+                                                  (Zadd
+                                                     (Zadd
+                                                        (Zadd
+                                                           (Zadd
+                                                              (Zadd (Zadd (Zadd (Zmul x7 y0) (Zmul x6 y1)) (Zmul x5 y2))
+                                                                 (Zmul x4 y3)) (Zmul x3 y4)) (Zmul x2 y5))
+                                                        (Zmul x1 y6)) (Zmul x0 y7))
+                                                  (Zmul (Zpos (xI (xI (xO (xO xH))))) (Zadd (Zmul x9 y8) (Zmul x8 y9)))))
+                                            (Zpos (xI (xO (xO (xI xH))))))
+                                         (Zadd
+                                            (Zadd
+                                               (Zadd
+                                                  (Zadd
+                                                     (Zadd
+                                                        (Zadd
+                                                           (Zadd
+                                                              (Zadd (Zadd (Zmul x8 y0) (Zmul (Zmul x7 y1) (Zpos (xO xH))))
+                                                                 (Zmul x6 y2)) (Zmul (Zmul x5 y3) (Zpos (xO xH))))
+                                                           (Zmul x4 y4)) (Zmul (Zmul x3 y5) (Zpos (xO xH))))
+                                                     (Zmul x2 y6)) (Zmul (Zmul x1 y7) (Zpos (xO xH)))) (Zmul x0 y8))
+                                            (Zmul (Zmul (Zmul (Zpos (xI (xI (xO (xO xH))))) x9) y9) (Zpos (xO xH)))))
+                                      (Zpos
+                                         (xI
+                                            (xI
+                                               (xI
+                                                  (xI
+                                                     (xI
+                                                        (xI
+                                                           (xI
+                                                              (xI
+                                                                 (xI
+                                                                    (xI
+                                                                       (xI
+                                                                          (xI
+                                                                             (xI
+                                                                                (xI
+                                                                                   (xI
+                                                                                      (xI
+                                                                                         (xI
+                                                                                            (xI
+                                                                                               (xI (xI (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))))
+                                   (@cons Z
+                                      (Z.land
+                                         (Zadd
+                                            (Z.shiftr
+                                               (Zadd
+                                                  (Z.shiftr
+                                                     (Zadd
+                                                        (Z.shiftr
+                                                           (Zadd
+                                                              (Z.shiftr
+                                                                 (Zadd
+                                                                    (Z.shiftr
+                                                                       (Zadd
+                                                                          (Z.shiftr
+                                                                             (Zadd
+                                                                                (Z.shiftr
+                                                                                   (Zadd
+                                                                                      (Z.shiftr
+                                                                                         (Zadd
+                                                                                            (Z.shiftr
+                                                                                               (Zadd (Zmul x0 y0)
+                                                                                                  (Zmul
+                                                                                                     (Zpos (xI (xI (xO (xO xH)))))
+                                                                                                     (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zmul
+                                                                                                       (Zmul x9 y1)
+                                                                                                       (Zpos (xO xH)))
+                                                                                                       (Zmul x8 y2))
+                                                                                                       (Zmul
+                                                                                                       (Zmul x7 y3)
+                                                                                                       (Zpos (xO xH))))
+                                                                                                       (Zmul x6 y4))
+                                                                                                       (Zmul
+                                                                                                       (Zmul x5 y5)
+                                                                                                       (Zpos (xO xH))))
+                                                                                                       (Zmul x4 y6))
+                                                                                                       (Zmul
+                                                                                                       (Zmul x3 y7)
+                                                                                                       (Zpos (xO xH))))
+                                                                                                       (Zmul x2 y8))
+                                                                                                       (Zmul
+                                                                                                       (Zmul x1 y9)
+                                                                                                       (Zpos (xO xH))))))
+                                                                                               (Zpos (xO (xI (xO (xI xH))))))
+                                                                                            (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1))
+                                                                                               (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                                                  (Zadd
+                                                                                                     (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zmul x9 y2)
+                                                                                                       (Zmul x8 y3))
+                                                                                                       (Zmul x7 y4))
+                                                                                                       (Zmul x6 y5))
+                                                                                                       (Zmul x5 y6))
+                                                                                                       (Zmul x4 y7))
+                                                                                                       (Zmul x3 y8))
+                                                                                                     (Zmul x2 y9)))))
+                                                                                         (Zpos (xI (xO (xO (xI xH))))))
+                                                                                      (Zadd
+                                                                                         (Zadd
+                                                                                            (Zadd (Zmul x2 y0)
+                                                                                               (Zmul (Zmul x1 y1) (Zpos (xO xH))))
+                                                                                            (Zmul x0 y2))
+                                                                                         (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                                            (Zadd
+                                                                                               (Zadd
+                                                                                                  (Zadd
+                                                                                                     (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zadd
+                                                                                                       (Zmul
+                                                                                                       (Zmul x9 y3)
+                                                                                                       (Zpos (xO xH)))
+                                                                                                       (Zmul x8 y4))
+                                                                                                       (Zmul
+                                                                                                       (Zmul x7 y5)
+                                                                                                       (Zpos (xO xH))))
+                                                                                                       (Zmul x6 y6))
+                                                                                                     (Zmul
+                                                                                                       (Zmul x5 y7)
+                                                                                                       (Zpos (xO xH))))
+                                                                                                  (Zmul x4 y8))
+                                                                                               (Zmul (Zmul x3 y9) (Zpos (xO xH)))))))
+                                                                                   (Zpos (xO (xI (xO (xI xH))))))
+                                                                                (Zadd
+                                                                                   (Zadd
+                                                                                      (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1))
+                                                                                         (Zmul x1 y2)) (Zmul x0 y3))
+                                                                                   (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                                      (Zadd
+                                                                                         (Zadd
+                                                                                            (Zadd
+                                                                                               (Zadd
+                                                                                                  (Zadd (Zmul x9 y4) (Zmul x8 y5))
+                                                                                                  (Zmul x7 y6))
+                                                                                               (Zmul x6 y7))
+                                                                                            (Zmul x5 y8))
+                                                                                         (Zmul x4 y9)))))
+                                                                             (Zpos (xI (xO (xO (xI xH))))))
+                                                                          (Zadd
+                                                                             (Zadd
+                                                                                (Zadd
+                                                                                   (Zadd
+                                                                                      (Zadd (Zmul x4 y0)
+                                                                                         (Zmul (Zmul x3 y1) (Zpos (xO xH))))
+                                                                                      (Zmul x2 y2))
+                                                                                   (Zmul (Zmul x1 y3) (Zpos (xO xH))))
+                                                                                (Zmul x0 y4))
+                                                                             (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                                (Zadd
+                                                                                   (Zadd
+                                                                                      (Zadd
+                                                                                         (Zadd (Zmul (Zmul x9 y5) (Zpos (xO xH)))
+                                                                                            (Zmul x8 y6))
+                                                                                         (Zmul (Zmul x7 y7) (Zpos (xO xH))))
+                                                                                      (Zmul x6 y8))
+                                                                                   (Zmul (Zmul x5 y9) (Zpos (xO xH)))))))
+                                                                       (Zpos (xO (xI (xO (xI xH))))))
+                                                                    (Zadd
+                                                                       (Zadd
+                                                                          (Zadd
+                                                                             (Zadd
+                                                                                (Zadd (Zadd (Zmul x5 y0) (Zmul x4 y1)) (Zmul x3 y2))
+                                                                                (Zmul x2 y3)) (Zmul x1 y4))
+                                                                          (Zmul x0 y5))
+                                                                       (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                          (Zadd (Zadd (Zadd (Zmul x9 y6) (Zmul x8 y7)) (Zmul x7 y8))
+                                                                             (Zmul x6 y9))))) (Zpos (xI (xO (xO (xI xH))))))
+                                                              (Zadd
+                                                                 (Zadd
+                                                                    (Zadd
+                                                                       (Zadd
+                                                                          (Zadd
+                                                                             (Zadd
+                                                                                (Zadd (Zmul x6 y0)
+                                                                                   (Zmul (Zmul x5 y1) (Zpos (xO xH))))
+                                                                                (Zmul x4 y2)) (Zmul (Zmul x3 y3) (Zpos (xO xH))))
+                                                                          (Zmul x2 y4)) (Zmul (Zmul x1 y5) (Zpos (xO xH))))
+                                                                    (Zmul x0 y6))
+                                                                 (Zmul (Zpos (xI (xI (xO (xO xH)))))
+                                                                    (Zadd (Zadd (Zmul (Zmul x9 y7) (Zpos (xO xH))) (Zmul x8 y8))
+                                                                       (Zmul (Zmul x7 y9) (Zpos (xO xH)))))))
+                                                           (Zpos (xO (xI (xO (xI xH))))))
+                                                        (Zadd
+                                                           (Zadd
+                                                              (Zadd
+                                                                 (Zadd
+                                                                    (Zadd
+                                                                       (Zadd (Zadd (Zadd (Zmul x7 y0) (Zmul x6 y1)) (Zmul x5 y2))
+                                                                          (Zmul x4 y3)) (Zmul x3 y4)) (Zmul x2 y5))
+                                                                 (Zmul x1 y6)) (Zmul x0 y7))
+                                                           (Zmul (Zpos (xI (xI (xO (xO xH))))) (Zadd (Zmul x9 y8) (Zmul x8 y9)))))
+                                                     (Zpos (xI (xO (xO (xI xH))))))
+                                                  (Zadd
+                                                     (Zadd
+                                                        (Zadd
+                                                           (Zadd
+                                                              (Zadd
+                                                                 (Zadd
+                                                                    (Zadd
+                                                                       (Zadd (Zadd (Zmul x8 y0) (Zmul (Zmul x7 y1) (Zpos (xO xH))))
+                                                                          (Zmul x6 y2)) (Zmul (Zmul x5 y3) (Zpos (xO xH))))
+                                                                    (Zmul x4 y4)) (Zmul (Zmul x3 y5) (Zpos (xO xH))))
+                                                              (Zmul x2 y6)) (Zmul (Zmul x1 y7) (Zpos (xO xH))))
+                                                        (Zmul x0 y8))
+                                                     (Zmul (Zmul (Zmul (Zpos (xI (xI (xO (xO xH))))) x9) y9) (Zpos (xO xH)))))
+                                               (Zpos (xO (xI (xO (xI xH))))))
+                                            (Zadd
+                                               (Zadd
+                                                  (Zadd
+                                                     (Zadd
+                                                        (Zadd
+                                                           (Zadd
+                                                              (Zadd (Zadd (Zadd (Zmul x9 y0) (Zmul x8 y1)) (Zmul x7 y2))
+                                                                 (Zmul x6 y3)) (Zmul x5 y4)) (Zmul x4 y5))
+                                                        (Zmul x3 y6)) (Zmul x2 y7)) (Zmul x1 y8)) (Zmul x0 y9)))
+                                         (Zpos
+                                            (xI
+                                               (xI
+                                                  (xI
+                                                     (xI
+                                                        (xI
+                                                           (xI
+                                                              (xI
+                                                                 (xI
+                                                                    (xI
+                                                                       (xI
+                                                                          (xI
+                                                                             (xI
+                                                                                (xI
+                                                                                   (xI
+                                                                                      (xI
+                                                                                         (xI
+                                                                                            (xI
+                                                                                               (xI (xI (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))
+                                      (@nil Z)))))))))))).
+  cbv beta zeta.
+  intros.
+  (timeout 1 (apply f_equal; reflexivity)) || fail 0 "too early".
+  Undo.
+  Time Timeout 1 f_equal. (* Finished transaction in 0. secs (0.3u,0.s) in 8.4 *)
diff --git a/test-suite/bugs/closed/4813.v b/test-suite/bugs/closed/4813.v
new file mode 100644
index 00000000..5f8ea74c
--- /dev/null
+++ b/test-suite/bugs/closed/4813.v
@@ -0,0 +1,9 @@
+(* On the strength of "apply with" (see also #4782) *)
+
+Record ProverT := { Facts : Type }.
+Record ProverT_correct (P : ProverT) :=  { Valid : Facts P -> Prop ;
+                                           Valid_weaken : Valid = Valid }.
+Definition reflexivityValid (_ : unit) := True.
+Definition reflexivityProver_correct : ProverT_correct {| Facts := unit |}.
+Proof.
+    eapply Build_ProverT_correct with (Valid := reflexivityValid).
diff --git a/test-suite/bugs/closed/4816.v b/test-suite/bugs/closed/4816.v
new file mode 100644
index 00000000..00a52384
--- /dev/null
+++ b/test-suite/bugs/closed/4816.v
@@ -0,0 +1,29 @@
+Section foo.
+Polymorphic Universes A B.
+Fail Constraint A <= B.
+End foo.
+(* gives an anomaly Universe undefined *)
+
+Universes X Y.
+Section Foo.
+  Polymorphic Universes Z W.
+  Polymorphic Constraint W < Z.
+
+  Fail Definition bla := Type@{W}.
+  Polymorphic Definition bla := Type@{W}.
+  Section Bar.
+    Fail Constraint X <= Z.
+  End Bar.
+End Foo.
+
+Require Coq.Classes.RelationClasses.
+
+Class PreOrder (A : Type) (r : A -> A -> Type) : Type :=
+{ refl : forall x, r x x }.
+
+Section qux.
+  Polymorphic Universes A.
+  Section bar.
+    Fail Context {A : Type@{A}} {rA : A -> A -> Prop} {PO : PreOrder A rA}.
+  End bar.
+End qux.
diff --git a/test-suite/bugs/closed/4818.v b/test-suite/bugs/closed/4818.v
new file mode 100644
index 00000000..904abb22
--- /dev/null
+++ b/test-suite/bugs/closed/4818.v
@@ -0,0 +1,24 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-R" "." "Prob" "-top" "Product") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 391 lines to 77 lines, then from 857 lines to 119 lines, then from 1584 lines to 126 lines, then from 362 lines to 135 lines, then from 149 lines to 135 lines *)
+(* coqc version 8.5pl1 (June 2016) compiled on Jun 9 2016 17:27:17 with OCaml 4.02.3
+   coqtop version 8.5pl1 (June 2016) *)
+Set Universe Polymorphism.
+
+Inductive GCov (I : Type) : Type := | Foo : I -> GCov I.
+
+Section Product.
+
+Variables S IS : Type.
+Variable locS : IS -> True.
+
+Goal GCov (IS * S) -> GCov IS.
+intros X0. induction X0; intros.
+destruct i.
+specialize (locS i).
+clear -locS. 
+destruct locS. Show Universes.
+Admitted.
+
+(*
+Anomaly: Universe Product.5189 undefined. Please report.
+*)
diff --git a/test-suite/bugs/closed/4858.v b/test-suite/bugs/closed/4858.v
new file mode 100644
index 00000000..a2fa9383
--- /dev/null
+++ b/test-suite/bugs/closed/4858.v
@@ -0,0 +1,7 @@
+Require Import Nsatz.
+Goal True.
+try nsatz_compute
+ (PEc 0%Z :: PEc (-1)%Z
+    :: PEpow (PEsub (PEX Z 2) (PEX Z 3)) 1
+       :: PEsub (PEX Z 1) (PEX Z 1) :: nil).
+Abort.
diff --git a/test-suite/bugs/closed/4863.v b/test-suite/bugs/closed/4863.v
new file mode 100644
index 00000000..1e47f295
--- /dev/null
+++ b/test-suite/bugs/closed/4863.v
@@ -0,0 +1,33 @@
+Require Import Classes.DecidableClass.
+
+Inductive Foo : Set :=
+| foo1 | foo2.
+
+Lemma Decidable_sumbool : forall P, {P}+{~P} -> Decidable P.
+Proof.
+  intros P H.
+  refine (Build_Decidable _ (if H then true else false) _).
+  intuition congruence.
+Qed.
+
+Hint Extern 100 (Decidable (?A = ?B)) => abstract (abstract (abstract (apply Decidable_sumbool; decide equality))) : typeclass_instances.
+
+Goal forall (a b : Foo), {a=b}+{a<>b}.
+intros.
+abstract (abstract (decide equality)). (*abstract works here*)
+Qed.
+
+Check ltac:(abstract (exact I)) : True.
+
+Goal forall (a b : Foo), Decidable (a=b) * Decidable (a=b).
+intros.
+split. typeclasses eauto. 
+typeclasses eauto. Qed.
+
+Goal forall (a b : Foo), Decidable (a=b) * Decidable (a=b).
+intros.
+split.
+refine _.
+refine _.
+Defined.
+(*fails*)
diff --git a/test-suite/bugs/closed/4865.v b/test-suite/bugs/closed/4865.v
new file mode 100644
index 00000000..c5bf3289
--- /dev/null
+++ b/test-suite/bugs/closed/4865.v
@@ -0,0 +1,52 @@
+(* Check discharge of arguments scopes + other checks *)
+
+(* This is bug #4865 *)
+
+Notation "<T>" := true : bool_scope.
+Section A.
+  Check negb <T>.
+  Global Arguments negb : clear scopes.
+  Fail Check negb <T>.
+End A.
+
+(* Check that no scope is re-computed *)
+Fail Check negb <T>.
+
+(* Another test about arguments scopes in sections *)
+
+Notation "0" := true.
+Section B.
+  Variable x : nat.
+  Let T := nat -> nat.
+  Definition f y : T := fun z => x + y + z.
+  Fail Check f 1 0.   (* 0 in nat, 0 in bool *)
+  Fail Check f 0 0.   (* 0 in nat, 0 in bool *)
+  Check f 0 1.        (* 0 and 1 in nat *)
+  Global Arguments f _%nat_scope _%nat_scope.
+  Check f 0 0.        (* both 0 in nat *)
+End B.
+
+(* Check that only the scope for the extra product on x is re-computed *)
+Check f 0 0 0.   (* All 0 in nat *)
+
+Section C.
+  Variable x : nat.
+  Let T := nat -> nat.
+  Definition g y : T := fun z => x + y + z.
+  Global Arguments g : clear scopes.
+  Check g 1.          (* 1 in nat *)
+End C.
+
+(* Check that only the scope for the extra product on x is re-computed *)
+Check g 0.            (* 0 in nat *)
+Fail Check g 0 1 0. (* 2nd 0 in bool *)
+Fail Check g 0 0 1. (* 2nd 0 in bool *)
+
+(* Another test on arguments scopes: checking scope for expanding arities *)
+(* Not sure this is very useful, but why not *)
+                  
+Fixpoint arr n := match n with 0%nat => nat | S n => nat -> arr n end.
+Fixpoint lam n : arr n := match n with 0%nat => 0%nat | S n => fun x => lam n  end.
+Notation "0" := true.
+Arguments Scope lam [nat_scope nat_scope].
+Check (lam 1 0).
diff --git a/test-suite/bugs/closed/4869.v b/test-suite/bugs/closed/4869.v
new file mode 100644
index 00000000..6d21b66f
--- /dev/null
+++ b/test-suite/bugs/closed/4869.v
@@ -0,0 +1,18 @@
+Universes i.
+
+Fail Constraint i < Set.
+Fail Constraint i <= Set.
+Fail Constraint i = Set.
+Constraint Set <= i.
+Constraint Set < i.
+Fail Constraint i < j. (* undeclared j *)
+Fail Constraint i < Type. (* anonymous *)
+
+Set Universe Polymorphism.
+
+Section Foo.
+  Universe j.
+  Constraint Set < j.
+
+  Definition foo := Type@{j}.
+End Foo.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4873.v b/test-suite/bugs/closed/4873.v
new file mode 100644
index 00000000..f2f917b4
--- /dev/null
+++ b/test-suite/bugs/closed/4873.v
@@ -0,0 +1,72 @@
+Require Import Coq.Classes.Morphisms.
+Require Import Relation_Definitions.
+Require Import Coq.Compat.Coq85.
+
+Fixpoint tuple' T n : Type :=
+  match n with
+  | O => T
+  | S n' => (tuple' T n' * T)%type
+  end.
+
+Definition tuple T n : Type :=
+  match n with
+  | O => unit
+  | S n' => tuple' T n'
+  end.
+
+Fixpoint to_list' {T} (n:nat) {struct n} : tuple' T n -> list T :=
+  match n with
+  | 0 => fun x => (x::nil)%list
+  | S n' => fun xs : tuple' T (S n') => let (xs', x) := xs in (x :: to_list' n' xs')%list
+  end.
+
+Definition to_list {T} (n:nat) : tuple T n -> list T :=
+  match n with
+  | 0 => fun _ => nil
+  | S n' => fun xs : tuple T (S n') => to_list' n' xs
+  end.
+
+Program Fixpoint from_list' {T} (y:T) (n:nat) (xs:list T) : length xs = n -> tuple' T n :=
+  match n return _ with
+  | 0 =>
+    match xs return (length xs = 0 -> tuple' T 0) with
+    | nil => fun _ => y
+    | _ => _ (* impossible *)
+    end
+  | S n' =>
+    match xs return (length xs = S n' -> tuple' T (S n')) with
+    | cons x xs' => fun _ => (from_list' x n' xs' _, y)
+    | _ => _ (* impossible *)
+    end
+  end.
+Goal True.
+  pose from_list'_obligation_3 as e.
+  repeat (let e' := fresh in
+          rename e into e';
+          (pose (e' nat) as e || pose (e' 0) as e || pose (e' nil) as e || pose (e' eq_refl) as e);
+          subst e').
+  progress hnf in e.
+  pose (eq_refl : e = eq_refl).
+  exact I.
+Qed.
+
+Program Definition from_list {T} (n:nat) (xs:list T) : length xs = n -> tuple T n :=
+match n return _ with
+| 0 =>
+    match xs return (length xs = 0 -> tuple T 0) with
+    | nil => fun _ : 0 = 0 => tt
+    | _ => _ (* impossible *)
+    end
+| S n' =>
+    match xs return (length xs = S n' -> tuple T (S n')) with
+    | cons x xs' => fun _ => from_list' x n' xs' _
+    | _ => _ (* impossible *)
+    end
+end.
+
+Lemma to_list_from_list : forall {T} (n:nat) (xs:list T) pf, to_list n (from_list n xs pf) = xs.
+Proof.
+  destruct xs; simpl; intros; subst; auto.
+  generalize dependent t. simpl in *.
+  induction xs; simpl in *; intros; congruence.
+Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4877.v b/test-suite/bugs/closed/4877.v
new file mode 100644
index 00000000..7e3c78dc
--- /dev/null
+++ b/test-suite/bugs/closed/4877.v
@@ -0,0 +1,12 @@
+Ltac induction_last :=
+  let v := match goal with
+           | |- forall x y, _ = _ -> _ => 1
+           | |- forall x y, _ -> _ = _ -> _ => 2
+           | |- forall x y, _ -> _ -> _ = _ -> _ => 3
+           end in
+  induction v.
+
+Goal forall n m : nat, True -> n = m -> m = n.
+  induction_last.
+  reflexivity.
+Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4880.v b/test-suite/bugs/closed/4880.v
new file mode 100644
index 00000000..5569798d
--- /dev/null
+++ b/test-suite/bugs/closed/4880.v
@@ -0,0 +1,11 @@
+Require Import Coq.Reals.Reals Coq.nsatz.Nsatz.
+Local Open Scope R.
+
+Goal forall x y : R,
+  x*x =  y *  y ->
+  x*x = -y * -y ->
+  x*(x*x) = 0 -> (* The associativity does not actually matter, *)
+  (x*x)*x = 0.   (* just otherwise [assumption] would solve the goal. *)
+Proof.
+  nsatz.
+Qed.
diff --git a/test-suite/bugs/closed/4882.v b/test-suite/bugs/closed/4882.v
new file mode 100644
index 00000000..8c26af70
--- /dev/null
+++ b/test-suite/bugs/closed/4882.v
@@ -0,0 +1,50 @@
+
+Definition Foo {T}{a : T} : T := a.
+
+Module A.
+
+  Declare Implicit Tactic eauto.
+
+  Goal forall A (x : A), A.
+  intros.
+  apply Foo. (* Check defined evars are normalized *)
+  (*  Qed. *)
+  Abort.
+
+End A.
+
+Module B.
+
+  Definition Foo {T}{a : T} : T := a.
+
+  Declare Implicit Tactic eassumption.
+
+  Goal forall A (x : A), A.
+  intros.
+  apply Foo.
+  (*  Qed. *)
+  Abort.
+
+End B.
+
+Module C.
+
+  Declare Implicit Tactic first [exact True|assumption].
+
+  Goal forall (x : True), True.
+  intros.
+  apply (@Foo _ _).
+  Qed.
+
+End C.
+
+Module D.
+
+  Declare Implicit Tactic assumption.
+
+  Goal forall A (x : A), A.
+  intros.
+  exact _.
+  Qed.
+
+End D.
diff --git a/test-suite/bugs/closed/4893.v b/test-suite/bugs/closed/4893.v
new file mode 100644
index 00000000..9a35bcf9
--- /dev/null
+++ b/test-suite/bugs/closed/4893.v
@@ -0,0 +1,4 @@
+Goal True.
+evar (P: Prop).
+assert (H : P); [|subst P]; [exact I|].
+let T := type of H in not_evar T.
diff --git a/test-suite/bugs/closed/4904.v b/test-suite/bugs/closed/4904.v
new file mode 100644
index 00000000..a47c3b07
--- /dev/null
+++ b/test-suite/bugs/closed/4904.v
@@ -0,0 +1,11 @@
+Module A.
+Module B.
+Notation mynat := nat.
+Notation nat := nat.
+End B.
+End A.
+
+Print A.B.nat. (* Notation A.B.nat := nat *)
+Import A.
+Print B.mynat.
+Print B.nat.
diff --git a/test-suite/bugs/closed/4932.v b/test-suite/bugs/closed/4932.v
new file mode 100644
index 00000000..219d532a
--- /dev/null
+++ b/test-suite/bugs/closed/4932.v
@@ -0,0 +1,44 @@
+(* Testing recursive notations with binders seen as terms *)
+
+Inductive ftele : Type :=
+| fb {T:Type} : T -> ftele
+| fr {T} : (T -> ftele) -> ftele.
+
+Fixpoint args ftele : Type :=
+  match ftele with
+    | fb _ => unit
+    | fr f => sigT (fun t => args (f t))
+  end.
+
+Definition fpack := sigT args.
+Definition pack fp fa : fpack := existT _ fp fa.
+
+Notation "'tele' x .. z := b" :=
+  (
+    (fun x => ..
+                (fun z =>
+                   pack
+                     (fr (fun x => .. ( fr (fun z => fb b) ) .. ) )
+                     (existT _ x .. (existT _ z tt) .. )
+                ) ..
+    )
+  ) (at level 85, x binder, z binder).
+
+Check fun '((y,z):nat*nat) => pack (fr (fun '((y,z):nat*nat) => fb tt))
+                                   (existT _ (y,z) tt).
+
+Example test := tele (t : Type) := tt.
+Example test' := test nat.
+Print test.
+
+Example test2 := tele (t : Type) (x:t) := tt.
+Example test2' := test2 nat 0.
+Print test2.
+
+Example test3 := tele (t : Type) (y:=0) (x:t) := tt.
+Example test3' := test3 nat 0.
+Print test3.
+
+Example test4 := tele (t : Type) '((y,z):nat*nat) (x:t) := tt.
+Example test4' := test4 nat (1,2) 3.
+Print test4.
diff --git a/test-suite/bugs/closed/4955.v b/test-suite/bugs/closed/4955.v
new file mode 100644
index 00000000..dce1f764
--- /dev/null
+++ b/test-suite/bugs/closed/4955.v
@@ -0,0 +1,98 @@
+(* An example involving a first-order unification triggering a cyclic constraint *)
+
+Module A.
+Notation "{ x : A | P }" := (sigT (fun x:A => P)).
+Notation "( x ; y )" := (existT _ x y) : fibration_scope.
+Open Scope fibration_scope.
+Notation "p @ q" := (eq_trans p q) (at level 20).
+Notation "p ^" := (eq_sym p) (at level 3).
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) 
+: P y :=
+  match p with eq_refl => 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 eq_refl => eq_refl 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 eq_refl => eq_refl end.
+Axiom transport_compose
+  : forall {A B} {x y : A} (P : B -> Type) (f : A -> B) (p : x = y) (z : P (f 
+x)),
+    transport (fun x => P (f x)) p z  =  transport P (ap f p) z.
+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 }.
+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) }.
+Arguments object_of {C%category D%category} f%functor c%object : rename, simpl 
+nomatch.
+Arguments morphism_of [C%category] [D%category] f%functor [s%object d%object] 
+m%morphism : rename, simpl nomatch.
+Section path_functor.
+  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_inv (F G : Functor C D) : F = G -> 
+path_functor'_T F G
+    := fun H'
+       => (ap object_of H';
+             (transport_compose _ object_of _ _) ^ @ apD (@morphism_of _ _) H').
+
+End path_functor.
+End A.
+
+(* A variant of it with more axioms *)
+
+Module B.
+Notation "{ x : A | P }" := (sigT (fun x:A => P)).
+Notation "( x ; y )" := (existT _ x y).
+Notation "p @ q" := (eq_trans p q) (at level 20).
+Notation "p ^" := (eq_sym p) (at level 3).
+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 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.
+Axiom apD : forall {A:Type} {B:A->Type} (f:forall a:A, B a) {x y:A} (p:x=y), p # (f 
+x) = f y.
+Axiom transport_compose
+  : forall {A B} {x y : A} (P : B -> Type) (f : A -> B) (p : x = y) (z : P (f 
+x)),
+    transport (fun x => P (f x)) p z  =  transport P (ap f p) z.
+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) }.
+Arguments object_of {C D} f c : rename, simpl nomatch.
+Arguments morphism_of [C] [D] f [s d] m : rename, simpl nomatch.
+Section path_functor.
+  Variable C 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 }.
+  Definition path_functor'_sig_inv (F G : Functor C D) : F = G -> 
+path_functor'_T F G
+    := fun H'
+       => (ap object_of H';
+             (transport_compose _ object_of _ _) ^ @ apD (@morphism_of _ _) H').
+
+End path_functor.
+End B.
diff --git a/test-suite/bugs/closed/4966.v b/test-suite/bugs/closed/4966.v
new file mode 100644
index 00000000..bd93cdc8
--- /dev/null
+++ b/test-suite/bugs/closed/4966.v
@@ -0,0 +1,10 @@
+(* Interpretation of auto as an argument of an ltac function (i.e. as an ident) was wrongly "auto with *" *)
+
+Axiom proof_admitted : False.
+Hint Extern 0 => case proof_admitted : unused.
+Ltac do_tac tac := tac.
+
+Goal False.
+  Set Ltac Profiling.
+  Fail solve [ do_tac auto ].
+Abort.
diff --git a/test-suite/bugs/closed/4970.v b/test-suite/bugs/closed/4970.v
new file mode 100644
index 00000000..7a896582
--- /dev/null
+++ b/test-suite/bugs/closed/4970.v
@@ -0,0 +1,3 @@
+(* Check "{{" is not confused with "{" in notations *)
+Reserved Notation "x {{ y }}" (at level 40).
+Notation "x {{ y }}" := (x y) (only parsing).
diff --git a/test-suite/bugs/closed/5011.v b/test-suite/bugs/closed/5011.v
new file mode 100644
index 00000000..c3043ca5
--- /dev/null
+++ b/test-suite/bugs/closed/5011.v
@@ -0,0 +1,2 @@
+Record decoder (n : nat) W := { decode : W -> nat }.
+Existing Class decoder.
diff --git a/test-suite/bugs/closed/5036.v b/test-suite/bugs/closed/5036.v
new file mode 100644
index 00000000..12c958be
--- /dev/null
+++ b/test-suite/bugs/closed/5036.v
@@ -0,0 +1,10 @@
+Section foo.
+  Context (F : Type -> Type).
+  Context (admit : forall {T}, F T = True).
+  Hint Rewrite (fun T => @admit T).
+  Lemma bad : F False.
+  Proof.
+    autorewrite with core.
+    constructor.
+  Qed.
+End foo. (* Anomaly: Universe Top.16 undefined. Please report. *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/5043.v b/test-suite/bugs/closed/5043.v
new file mode 100644
index 00000000..4e6a0f87
--- /dev/null
+++ b/test-suite/bugs/closed/5043.v
@@ -0,0 +1,8 @@
+Unset Keep Admitted Variables.
+
+Section a.
+  Context (x : Type).
+  Definition foo : Type.
+  Admitted.
+End a.
+Check foo : Type.
diff --git a/test-suite/bugs/closed/5045.v b/test-suite/bugs/closed/5045.v
new file mode 100644
index 00000000..dc38738d
--- /dev/null
+++ b/test-suite/bugs/closed/5045.v
@@ -0,0 +1,3 @@
+Axiom silly : 1 = 1 -> nat -> nat.
+Goal forall pf : 1 = 1, silly pf 0 = 0 -> True.
+  Fail generalize (@eq nat).
diff --git a/test-suite/bugs/closed/5065.v b/test-suite/bugs/closed/5065.v
new file mode 100644
index 00000000..6bd677ba
--- /dev/null
+++ b/test-suite/bugs/closed/5065.v
@@ -0,0 +1,6 @@
+Inductive foo := C1 : bar -> foo with bar := C2 : foo -> bar.
+
+Lemma L1 : foo -> True with L2 : bar -> True.
+intros; clear L1 L2; abstract (exact I).
+intros; exact I.
+Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/5066.v b/test-suite/bugs/closed/5066.v
new file mode 100644
index 00000000..eed7f0f3
--- /dev/null
+++ b/test-suite/bugs/closed/5066.v
@@ -0,0 +1,7 @@
+Require Import Vector.
+
+Fail Program Fixpoint vector_rev {A : Type} {n1 n2 : nat} (v1 : Vector.t A n1) (v2 : Vector.t A n2) : Vector.t A (n1+n2) :=
+  match v1 with
+  | nil _          => v2
+  | cons _ e n' sv => vector_rev sv (cons A e n2 v2)
+  end.
diff --git a/test-suite/bugs/closed/5077.v b/test-suite/bugs/closed/5077.v
new file mode 100644
index 00000000..7e7f2c37
--- /dev/null
+++ b/test-suite/bugs/closed/5077.v
@@ -0,0 +1,8 @@
+(* Testing robustness of typing for a fixpoint with evars in its type *)
+
+Inductive foo (n : nat) : Type := .
+Definition foo_denote {n} (x : foo n) : Type := match x with end.
+
+Definition baz : forall n (x : foo n), foo_denote x.
+refine (fix go n (x : foo n) : foo_denote x := _).
+Abort.  
diff --git a/test-suite/bugs/closed/5078.v b/test-suite/bugs/closed/5078.v
new file mode 100644
index 00000000..ca73cbcc
--- /dev/null
+++ b/test-suite/bugs/closed/5078.v
@@ -0,0 +1,5 @@
+(* Test coercion from ident to evaluable reference *)
+Tactic Notation "unfold_hyp" hyp(H) := cbv delta [H].
+Goal True -> Type.
+  intro H''.
+  Fail unfold_hyp H''.
diff --git a/test-suite/bugs/closed/5093.v b/test-suite/bugs/closed/5093.v
new file mode 100644
index 00000000..3ded4dd3
--- /dev/null
+++ b/test-suite/bugs/closed/5093.v
@@ -0,0 +1,11 @@
+Axiom P : nat -> Prop.
+Axiom PS : forall n, P n -> P (S n).
+Axiom P0 : P 0.
+
+Hint Resolve PS : foobar.
+Hint Resolve P0 : foobar.
+
+Goal P 100.
+Proof.
+Fail typeclasses eauto 100 with foobar.
+typeclasses eauto 101 with foobar.
diff --git a/test-suite/bugs/closed/5095.v b/test-suite/bugs/closed/5095.v
new file mode 100644
index 00000000..b6f38e3e
--- /dev/null
+++ b/test-suite/bugs/closed/5095.v
@@ -0,0 +1,5 @@
+(* Checking let-in abstraction *)
+Goal let x := Set in let y := x in True.
+  intros x y.
+  (* There used to have a too strict dependency test there *)
+  set (s := Set) in (value of x).
diff --git a/test-suite/bugs/closed/5096.v b/test-suite/bugs/closed/5096.v
new file mode 100644
index 00000000..20a537ab
--- /dev/null
+++ b/test-suite/bugs/closed/5096.v
@@ -0,0 +1,219 @@
+Require Import Coq.FSets.FMapPositive Coq.PArith.BinPos Coq.Lists.List.
+
+Set Asymmetric Patterns.
+
+Notation eta x := (fst x, snd x).
+
+Inductive expr {var : Type} : Type :=
+| Const : expr
+| LetIn : expr -> (var -> expr) -> expr.
+
+Definition Expr := forall var, @expr var.
+
+Fixpoint count_binders (e : @expr unit) : nat :=
+match e with
+| LetIn _ eC => 1 + @count_binders (eC tt)
+| _ => 0
+end.
+
+Definition CountBinders (e : Expr) : nat := count_binders (e _).
+
+Class Context (Name : Type) (var : Type) :=
+  { ContextT : Type;
+    extendb : ContextT -> Name -> var -> ContextT;
+    empty : ContextT }.
+Coercion ContextT : Context >-> Sortclass.
+Arguments ContextT {_ _ _}, {_ _} _.
+Arguments extendb {_ _ _} _ _ _.
+Arguments empty {_ _ _}.
+
+Module Export Named.
+Inductive expr Name : Type :=
+| Const : expr Name
+| LetIn : Name -> expr Name -> expr Name -> expr Name.
+End Named.
+
+Global Arguments Const {_}.
+Global Arguments LetIn {_} _ _ _.
+
+Definition split_onames {Name : Type} (ls : list (option Name))
+  : option (Name) * list (option Name)
+  := match ls with
+          | cons n ls'
+            => (n, ls')
+          | nil => (None, nil)
+     end.
+
+Section internal.
+  Context (InName OutName : Type)
+          {InContext : Context InName (OutName)}
+          {ReverseContext : Context OutName (InName)}
+          (InName_beq : InName -> InName -> bool).
+
+  Fixpoint register_reassign (ctxi : InContext) (ctxr : ReverseContext)
+           (e : expr InName) (new_names : list (option OutName))
+    : option (expr OutName)
+    := match e in Named.expr _ return option (expr _) with
+       | Const => Some Const
+       | LetIn n ex eC
+         => let '(n', new_names') := eta (split_onames new_names) in
+            match n', @register_reassign ctxi ctxr ex nil with
+            | Some n', Some x
+              => let ctxi := @extendb _ _ _ ctxi n n' in
+                 let ctxr := @extendb _ _ _ ctxr n' n in
+                 option_map (LetIn n' x) (@register_reassign ctxi ctxr eC new_names')
+            | None, Some x
+              => let ctxi := ctxi in
+                 @register_reassign ctxi ctxr eC new_names'
+            | _, None => None
+            end
+       end.
+
+End internal.
+
+Global Instance pos_context (var : Type) : Context positive var
+  := { ContextT := PositiveMap.t var;
+       extendb ctx key v := PositiveMap.add key v ctx;
+       empty := PositiveMap.empty _ }.
+
+Global Arguments register_reassign {_ _ _ _} ctxi ctxr e _.
+
+Section language5.
+  Context (Name : Type).
+
+  Local Notation expr := (@Top.expr Name).
+  Local Notation nexpr := (@Named.expr Name).
+
+  Fixpoint ocompile (e : expr) (ls : list (option Name)) {struct e}
+    : option (nexpr)
+    := match e in @Top.expr _ return option (nexpr) with
+       | Top.Const => Some Named.Const
+       | Top.LetIn ex eC
+         => match @ocompile ex nil, split_onames ls with
+            | Some x, (Some n, ls')%core
+              => option_map (fun C => Named.LetIn n x C) (@ocompile (eC n) ls')
+            | _, _ => None
+            end
+       end.
+
+  Definition compile (e : expr) (ls : list Name) := @ocompile e (List.map (@Some _) ls).
+End language5.
+
+Global Arguments compile {_} e ls.
+
+Fixpoint merge_liveness (ls1 ls2 : list unit) :=
+  match ls1, ls2 with
+  | cons x xs, cons y ys => cons tt (@merge_liveness xs ys)
+  | nil, ls | ls, nil => ls
+  end.
+
+Section internal1.
+  Context (Name : Type)
+          (OutName : Type)
+          {Context : Context Name (list unit)}.
+
+  Definition compute_livenessf_step
+             (compute_livenessf : forall (ctx : Context) (e : expr Name) (prefix : list unit), list unit)
+             (ctx : Context)
+             (e : expr Name) (prefix : list unit)
+    : list unit
+    := match e with
+       | Const => prefix
+       | LetIn n ex eC
+         => let lx := @compute_livenessf ctx ex prefix in
+            let lx := merge_liveness lx (prefix ++ repeat tt 1) in
+            let ctx := @extendb _ _ _ ctx n (lx) in
+            @compute_livenessf ctx eC (prefix ++ repeat tt 1)
+       end.
+
+  Fixpoint compute_liveness ctx e prefix
+    := @compute_livenessf_step (@compute_liveness) ctx e prefix.
+
+  Fixpoint insert_dead_names_gen def (ls : list unit) (lsn : list OutName)
+    : list (option OutName)
+    := match ls with
+       | nil => nil
+       | cons live xs
+         => match lsn with
+            | cons n lsn' => Some n :: @insert_dead_names_gen def xs lsn'
+            | nil => def :: @insert_dead_names_gen def xs nil
+            end
+       end.
+  Definition insert_dead_names def (e : expr Name)
+    := insert_dead_names_gen def (compute_liveness empty e nil).
+End internal1.
+
+Global Arguments insert_dead_names {_ _ _} def e lsn.
+
+Definition Let_In {A P} (x : A) (f : forall a : A, P a) : P x := let y := x in f y.
+
+Section language7.
+  Context {Context : Context unit (positive)}.
+
+  Local Notation nexpr := (@Named.expr unit).
+
+  Definition CompileAndEliminateDeadCode (e : Expr) (ls : list unit)
+    : option (nexpr)
+    := let e := compile (Name:=positive) (e _) (List.map Pos.of_nat (seq 1 (CountBinders e))) in
+       match e with
+       | Some e => Let_In (insert_dead_names None e ls) (* help vm_compute by factoring this out *)
+                          (fun names => register_reassign empty empty e names)
+       | None => None
+       end.
+End language7.
+
+Global Arguments CompileAndEliminateDeadCode {_} e ls.
+
+Definition ContextOn {Name1 Name2} f {var} (Ctx : Context Name1 var) : Context Name2 var
+  := {| ContextT := Ctx;
+        extendb ctx n v := extendb ctx (f n) v;
+        empty := empty |}.
+
+Definition Register := Datatypes.unit.
+
+Global Instance RegisterContext {var : Type} : Context Register var
+  := ContextOn (fun _ => 1%positive) (pos_context var).
+
+Definition syntax := Named.expr Register.
+
+Definition AssembleSyntax e ls (res := CompileAndEliminateDeadCode e ls)
+  := match res return match res with None => _ | _ => _ end with
+     | Some v => v
+     | None => I
+     end.
+
+Definition dummy_registers (n : nat) : list Register
+  := List.map (fun _ => tt) (seq 0 n).
+Definition DefaultRegisters (e : Expr) : list Register
+  := dummy_registers (CountBinders e).
+
+Definition DefaultAssembleSyntax e := @AssembleSyntax e (DefaultRegisters e).
+
+Notation "'slet' x := A 'in' b" := (Top.LetIn A (fun x => b)) (at level 200, b at level 200).
+Notation "#[ var ]#" := (@Top.Const var).
+
+Definition compiled_syntax : Expr := fun (var : Type) =>
+(
+  slet x1 := #[ var ]# in
+  slet x1 := #[ var ]# in
+  slet x1 := #[ var ]# in
+  slet x1 := #[ var ]# in
+  slet x1 := #[ var ]# in
+  slet x1 := #[ var ]# in
+  slet x1 := #[ var ]# in
+  slet x1 := #[ var ]# in
+  slet x1 := #[ var ]# in
+  slet x1 := #[ var ]# in
+  slet x1 := #[ var ]# in
+  slet x1 := #[ var ]# in
+  slet x1 := #[ var ]# in
+  slet x1 := #[ var ]# in
+  slet x1 := #[ var ]# in
+  slet x1 := #[ var ]# in
+  slet x1 := #[ var ]# in
+ @Top.Const var).
+
+Definition v :=
+  Eval cbv [compiled_syntax] in (DefaultAssembleSyntax (compiled_syntax)).
+
+Timeout 2 Eval vm_compute in v.
diff --git a/test-suite/bugs/closed/5097.v b/test-suite/bugs/closed/5097.v
new file mode 100644
index 00000000..37b239cf
--- /dev/null
+++ b/test-suite/bugs/closed/5097.v
@@ -0,0 +1,7 @@
+(* Tracing existing evars along the weakening rule ("clear") *)
+Goal forall y, exists x, x=0->x=y.
+intros.
+eexists ?[x].
+intros.
+let x:=constr:(ltac:(clear y; exact 0)) in idtac x.
+Abort.
diff --git a/test-suite/bugs/closed/5123.v b/test-suite/bugs/closed/5123.v
new file mode 100644
index 00000000..bcde510e
--- /dev/null
+++ b/test-suite/bugs/closed/5123.v
@@ -0,0 +1,33 @@
+(* IN 8.5pl2 and 8.6 (4da2131), the following shows different typeclass resolution behaviors following an unshelve tactical vs. an Unshelve command: *)
+
+(*Pose an open constr to prevent immediate typeclass resolution in holes:*)
+Tactic Notation "opose" open_constr(x) "as" ident(H) := pose x as H.
+
+Inductive vect A : nat -> Type :=
+| vnil : vect A 0
+| vcons : forall (h:A) (n:nat), vect A n -> vect A (S n).
+
+Class Eqdec A := eqdec : forall a b : A, {a=b}+{a<>b}.
+
+Require Bool.
+
+Instance Bool_eqdec : Eqdec bool := Bool.bool_dec.
+
+Context `{vect_sigT_eqdec : forall A : Type, Eqdec A -> Eqdec {a : nat & vect A a}}.
+
+Typeclasses eauto := debug.
+
+Goal True.
+  unshelve opose (@vect_sigT_eqdec _ _ _ _) as H.
+  all:cycle 2.
+  eapply existT. (*BUG: Why does this do typeclass resolution in the evar?*)
+  Focus 5.
+Abort.
+
+Goal True.
+  opose (@vect_sigT_eqdec _ _ _ _) as H.
+  Unshelve.
+  all:cycle 3.
+  eapply existT. (*This does no typeclass resultion, which is correct.*)
+  Focus 5.
+Abort.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/5127.v b/test-suite/bugs/closed/5127.v
new file mode 100644
index 00000000..831e8fb5
--- /dev/null
+++ b/test-suite/bugs/closed/5127.v
@@ -0,0 +1,15 @@
+Fixpoint arrow (n: nat) :=
+  match n with
+  | S n => bool -> arrow n
+  | O => bool
+  end.
+
+Fixpoint apply (n : nat) : arrow n -> bool :=
+  match n return arrow n -> bool with
+  | S n => fun f => apply _ (f true)
+  | O => fun x => x
+  end.
+
+Axiom f : arrow 10000.
+Definition v : bool := Eval compute in apply _ f.
+Definition w : bool := Eval vm_compute in v.
diff --git a/test-suite/bugs/closed/5145.v b/test-suite/bugs/closed/5145.v
new file mode 100644
index 00000000..0533d21e
--- /dev/null
+++ b/test-suite/bugs/closed/5145.v
@@ -0,0 +1,10 @@
+Class instructions :=
+  {
+    W : Type;
+    ldi : nat -> W
+  }.
+
+Fail Definition foo :=
+  let y2 := ldi 0 in
+  let '(CF, _) := (true, 0) in
+  y2.
diff --git a/test-suite/bugs/closed/5149.v b/test-suite/bugs/closed/5149.v
new file mode 100644
index 00000000..684dba19
--- /dev/null
+++ b/test-suite/bugs/closed/5149.v
@@ -0,0 +1,47 @@
+Goal forall x x' : nat, x = x' -> S x = S x -> exists y, S y = S x.
+intros.
+eexists.
+rewrite <- H.
+eassumption.
+Qed.
+
+Goal forall (base_type_code : Type) (t : base_type_code) (flat_type : Type) 
+            (t' : flat_type) (exprf interp_flat_type0 interp_flat_type1 : 
+flat_type -> Type)
+            (v v' : interp_flat_type1 t'),
+    v = v' ->
+    forall (interpf : forall t0 : flat_type, exprf t0 -> interp_flat_type1 t0)
+           (SmartVarVar : forall t0 : flat_type, interp_flat_type1 t0 -> 
+interp_flat_type0 t0)
+           (Tbase : base_type_code -> flat_type) (x : exprf (Tbase t))
+           (x' : interp_flat_type1 (Tbase t)) (T : Type)
+           (flatten_binding_list : forall t0 : flat_type,
+               interp_flat_type0 t0 -> interp_flat_type1 t0 -> list T)
+           (P : T -> list T -> Prop) (prod : Type -> Type -> Type)
+           (s : forall x0 : base_type_code, prod (exprf (Tbase x0)) 
+(interp_flat_type1 (Tbase x0)) -> T)
+           (pair : forall A B : Type, A -> B -> prod A B),
+      P (s t (pair (exprf (Tbase t)) (interp_flat_type1 (Tbase t)) x x'))
+        (flatten_binding_list t' (SmartVarVar t' v') v) ->
+      (forall (t0 : base_type_code) (t'0 : flat_type) (v0 : interp_flat_type1 
+t'0)
+              (x0 : exprf (Tbase t0)) (x'0 : interp_flat_type1 (Tbase t0)),
+          P (s t0 (pair (exprf (Tbase t0)) (interp_flat_type1 (Tbase t0)) x0 
+x'0))
+            (flatten_binding_list t'0 (SmartVarVar t'0 v0) v0) -> interpf 
+(Tbase t0) x0 = x'0) ->
+      interpf (Tbase t) x = x'.
+Proof.
+  intros ?????????????????????? interpf_SmartVarVar.
+  solve [ unshelve (subst; eapply interpf_SmartVarVar; eassumption) ] || fail 
+"too early".
+  Undo.
+  (** Implicitely at the dot. The first fails because unshelve adds a goal, and solve hence fails. The second has an ambiant unification problem that is solved after solve *)
+  Fail solve [ unshelve (eapply interpf_SmartVarVar; subst; eassumption) ].
+  solve [eapply interpf_SmartVarVar; subst; eassumption].
+  Undo.
+  Unset Solve Unification Constraints.
+  (* User control of when constraints are solved *)
+  solve [ unshelve (eapply interpf_SmartVarVar; subst; eassumption); solve_constraints ].
+Qed.
+
diff --git a/test-suite/bugs/closed/5161.v b/test-suite/bugs/closed/5161.v
new file mode 100644
index 00000000..d28303b8
--- /dev/null
+++ b/test-suite/bugs/closed/5161.v
@@ -0,0 +1,27 @@
+(* Check that the presence of binders with type annotation do not
+   prevent the recursive binder part to be found *)
+
+From Coq Require Import Utf8.
+
+Delimit Scope C_scope with C.
+Global Open Scope C_scope.
+
+Delimit Scope uPred_scope with I.
+
+Definition FORALL {T : Type} (f : T → Prop) : Prop := ∀ x, f x.
+
+Notation "∀ x .. y , P" :=
+  (FORALL (λ x, .. (FORALL (λ y, P)) ..)%I)
+  (at level 200, x binder, y binder, right associativity) : uPred_scope.
+Infix "∧" := and : uPred_scope.
+
+(* The next command fails with
+   In recursive notation with binders, Φ is expected to come without type.
+   I would expect this notation to work fine, since the ∀ does support
+   type annotation.
+*)
+Notation "'{{{' P } } } e {{{ x .. y ; pat , Q } } }" :=
+  (∀ Φ : _ → _,
+      (∀ x, .. (∀ y, Q ∧ Φ pat) .. ))%I
+    (at level 20, x closed binder, y closed binder,
+     format "{{{  P  } } }  e  {{{ x .. y ;  pat ,  Q } } }") : uPred_scope.
diff --git a/test-suite/bugs/closed/5180.v b/test-suite/bugs/closed/5180.v
new file mode 100644
index 00000000..261092ee
--- /dev/null
+++ b/test-suite/bugs/closed/5180.v
@@ -0,0 +1,64 @@
+Universes a b c ω ω'.
+Definition Typeω := Type@{ω}.
+Definition Type2 : Typeω := Type@{c}.
+Definition Type1 : Type2 := Type@{b}.
+Definition Type0 : Type1 := Type@{a}.
+
+Set Universe Polymorphism.
+Set Printing Universes.
+
+Definition Typei' (n : nat)
+  := match n return Type@{ω'} with
+     | 0 => Type0
+     | 1 => Type1
+     | 2 => Type2
+     | _ => Typeω
+     end.
+Definition TypeOfTypei' {n} (x : Typei' n) : Type@{ω'}
+  := match n return Typei' n -> Type@{ω'} with
+     | 0 | 1 | 2 | _ => fun x => x
+     end x.
+Definition Typei (n : nat) : Typei' (S n)
+  := match n return Typei' (S n) with
+     | 0 => Type0
+     | 1 => Type1
+     | _ => Type2
+     end.
+Definition TypeOfTypei {n} (x : TypeOfTypei' (Typei n)) : Type@{ω'}
+  := match n return TypeOfTypei' (Typei n) -> Type@{ω'} with
+     | 0 | 1 | _ => fun x => x
+     end x.
+Check Typei 0 : Typei 1.
+Check Typei 1 : Typei 2.
+
+Definition lift' {n} : TypeOfTypei' (Typei n) -> TypeOfTypei' (Typei (S n))
+  := match n return TypeOfTypei' (Typei n) -> TypeOfTypei' (Typei (S n)) with
+     | 0 | 1 | 2 | _ => fun x => (x : Type)
+     end.
+Definition lift'' {n} : TypeOfTypei' (Typei n) -> TypeOfTypei' (Typei (S n))
+  := match n return TypeOfTypei' (Typei n) -> TypeOfTypei' (Typei (S n)) with
+     | 0 | 1 | 2 | _ => fun x => x
+     end. (* The command has indeed failed with message:
+In environment
+n : nat
+x : TypeOfTypei' (Typei 0)
+The term "x" has type "TypeOfTypei' (Typei 0)" while it is expected to have type
+ "TypeOfTypei' (Typei 1)" (universe inconsistency: Cannot enforce b = a because  a < b).
+ *)
+Check (fun x : TypeOfTypei' (Typei 0) => TypeOfTypei' (Typei 1)).
+
+Definition lift''' {n} : TypeOfTypei' (Typei n) -> TypeOfTypei' (Typei (S n)).
+  refine match n return TypeOfTypei' (Typei n) -> TypeOfTypei' (Typei (S n))  with
+         | 0 | 1 | 2 | _ => fun x => _
+         end.
+  exact x.
+  Undo.
+  (* The command has indeed failed with message:
+In environment
+n : nat
+x : TypeOfTypei' (Typei 0)
+The term "x" has type "TypeOfTypei' (Typei 0)" while it is expected to have type
+ "TypeOfTypei' (Typei 1)" (universe inconsistency: Cannot enforce b = a because  a < b).
+ *)
+  all:compute in *.
+  all:exact x.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/5181.v b/test-suite/bugs/closed/5181.v
new file mode 100644
index 00000000..0e6d4719
--- /dev/null
+++ b/test-suite/bugs/closed/5181.v
@@ -0,0 +1,3 @@
+Definition foo (x y : nat) := x.
+Fail Arguments foo {_} : assert.
+
diff --git a/test-suite/bugs/closed/5188.v b/test-suite/bugs/closed/5188.v
new file mode 100644
index 00000000..e29ebfb4
--- /dev/null
+++ b/test-suite/bugs/closed/5188.v
@@ -0,0 +1,5 @@
+Set Printing All.
+Axiom relation : forall (T : Type), Set.
+Axiom T : forall A (R : relation A), Set.
+Set Printing Universes.
+Parameter (A:_) (R:_) (e:@T A R).
diff --git a/test-suite/bugs/closed/5198.v b/test-suite/bugs/closed/5198.v
new file mode 100644
index 00000000..7254afb4
--- /dev/null
+++ b/test-suite/bugs/closed/5198.v
@@ -0,0 +1,39 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-boot" "-nois") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 286 lines to 
+27 lines, then from 224 lines to 53 lines, then from 218 lines to 56 lines, 
+then from 269 lines to 180 lines, then from 132 lines to 48 lines, then from 
+253 lines to 65 lines, then from 79 lines to 65 lines *)
+(* coqc version 8.6.0 (November 2016) compiled on Nov 12 2016 14:43:52 with 
+OCaml 4.02.3
+   coqtop version jgross-Leopard-WS:/home/jgross/Downloads/coq/coq-v8.6,v8.6 
+(7e992fa784ee6fa48af8a2e461385c094985587d) *)
+Axiom admit : forall {T}, T.
+Set Printing Implicit.
+Inductive nat := O | S (_ : nat).
+Axiom f : forall (_ _ : nat), nat.
+Class ZLikeOps (e : nat)
+  := { LargeT : Type ; SmallT : Type ; CarryAdd : forall (_ _ : LargeT), LargeT 
+}.
+Class BarrettParameters :=
+  { b : nat ; k : nat ; ops : ZLikeOps (f b k) }.
+Axiom barrett_reduce_function_bundled : forall {params : BarrettParameters}
+                                               (_ : @LargeT _ (@ops params)),
+    @SmallT _ (@ops params).
+
+Global Instance ZZLikeOps e : ZLikeOps (f (S O) e)
+  := { LargeT := nat ; SmallT := nat ; CarryAdd x y := y }.
+Definition SRep := nat.
+Local Instance x86_25519_Barrett : BarrettParameters
+  := { b := S O ; k := O ; ops := ZZLikeOps O }.
+Definition SRepAdd : forall (_ _ : SRep), SRep
+  := let v := (fun x y => barrett_reduce_function_bundled (CarryAdd x y)) in
+     v.
+Definition SRepAdd' : forall (_ _ : SRep), SRep
+  := (fun x y => barrett_reduce_function_bundled (CarryAdd x y)).
+(* Error:
+In environment
+x : SRep
+y : SRep
+The term "x" has type "SRep" while it is expected to have type
+ "@LargeT ?e ?ZLikeOps".
+ *)
diff --git a/test-suite/bugs/closed/5203.v b/test-suite/bugs/closed/5203.v
new file mode 100644
index 00000000..ed137395
--- /dev/null
+++ b/test-suite/bugs/closed/5203.v
@@ -0,0 +1,5 @@
+Goal True.
+  Typeclasses eauto := debug.
+  Fail solve [ typeclasses eauto ].
+  Fail typeclasses eauto.
+  
\ No newline at end of file
diff --git a/test-suite/bugs/closed/5208.v b/test-suite/bugs/closed/5208.v
new file mode 100644
index 00000000..b7a684a2
--- /dev/null
+++ b/test-suite/bugs/closed/5208.v
@@ -0,0 +1,222 @@
+Require Import Program.
+
+Require Import Coq.Strings.String.
+Require Import Coq.Strings.Ascii.
+Require Import Coq.Numbers.BinNums.
+
+Set Implicit Arguments.
+Set Strict Implicit.
+Set Universe Polymorphism.
+Set Printing Universes.
+
+Local Open Scope positive.
+
+Definition field : Type := positive.
+
+Section poly.
+  Universe U.
+
+  Inductive fields : Type :=
+  | pm_Leaf : fields
+  | pm_Branch : fields -> option Type@{U} -> fields -> fields.
+
+  Definition fields_left (f : fields) : fields :=
+    match f with
+    | pm_Leaf => pm_Leaf
+    | pm_Branch l _ _ => l
+    end.
+
+  Definition fields_right (f : fields) : fields :=
+    match f with
+    | pm_Leaf => pm_Leaf
+    | pm_Branch _ _ r => r
+    end.
+
+  Definition fields_here (f : fields) : option Type@{U} :=
+    match f with
+    | pm_Leaf => None
+    | pm_Branch _ s _ => s
+    end.
+
+  Fixpoint fields_get (p : field) (m : fields) {struct p} : option Type@{U} :=
+    match p with
+      | xH => match m with
+                | pm_Leaf => None
+                | pm_Branch _ x _ => x
+              end
+      | xO p' => fields_get p' match m with
+                               | pm_Leaf => pm_Leaf
+                               | pm_Branch L _ _ => L
+                             end
+      | xI p' => fields_get p' match m with
+                               | pm_Leaf => pm_Leaf
+                               | pm_Branch _ _ R => R
+                             end
+    end.
+
+  Definition fields_leaf : fields := pm_Leaf.
+
+  Inductive member (val : Type@{U}) : fields -> Type :=
+  | pmm_H : forall L R, member val (pm_Branch L (Some val) R)
+  | pmm_L : forall (V : option Type@{U}) L R, member val L -> member val (pm_Branch L V R)
+  | pmm_R : forall (V : option Type@{U}) L R, member val R -> member val (pm_Branch L V R).
+  Arguments pmm_H {_ _ _}.
+  Arguments pmm_L {_ _ _ _} _.
+  Arguments pmm_R {_ _ _ _} _.
+
+  Fixpoint get_member (val : Type@{U}) p {struct p}
+  : forall m, fields_get p m = @Some Type@{U} val -> member val m :=
+    match p as p return forall m, fields_get p m = @Some Type@{U} val -> member@{U} val m with
+      | xH => fun m =>
+        match m as m return fields_get xH m = @Some Type@{U} val -> member@{U} val m with
+        | pm_Leaf => fun pf : None = @Some Type@{U} _ =>
+                       match pf in _ = Z return match Z with
+                                                | Some _ => _
+                                                | None => unit
+                                                end
+                       with
+                       | eq_refl => tt
+                       end
+        | pm_Branch _ None _ => fun pf : None = @Some Type@{U} _ =>
+                                  match pf in _ = Z return match Z with
+                                                           | Some _ => _
+                                                           | None => unit
+                                                           end
+                                  with
+                                  | eq_refl => tt
+                                  end
+        | pm_Branch _ (Some x) _ => fun pf : @Some Type@{U} x = @Some Type@{U} val =>
+                                      match eq_sym pf in _ = Z return member@{U} val (pm_Branch _ Z _) with
+                                      | eq_refl => pmm_H
+                                      end
+        end
+      | xO p' => fun m =>
+        match m as m return fields_get (xO p') m = @Some Type@{U} val -> member@{U} val m with
+        | pm_Leaf => fun pf : fields_get p' pm_Leaf = @Some Type@{U} val =>
+                       @get_member _ p' pm_Leaf pf
+        | pm_Branch l _ _ => fun pf : fields_get p' l = @Some Type@{U} val =>
+                       @pmm_L _ _ _ _ (@get_member _ p' l pf)
+        end
+      | xI p' => fun m =>
+        match m as m return fields_get (xI p') m = @Some Type@{U} val -> member@{U} val m with
+        | pm_Leaf => fun pf : fields_get p' pm_Leaf = @Some Type@{U} val =>
+                       @get_member _ p' pm_Leaf pf
+        | pm_Branch l _ r => fun pf : fields_get p' r = @Some Type@{U} val =>
+                               @pmm_R _ _ _ _ (@get_member _ p' r pf)
+        end
+    end.
+
+  Inductive record : fields -> Type :=
+  | pr_Leaf : record pm_Leaf
+  | pr_Branch : forall L R (V : option Type@{U}),
+      record L ->
+      match V return Type@{U} with
+        | None => unit
+        | Some t => t
+      end ->
+      record R ->
+      record (pm_Branch L V R).
+
+
+  Definition record_left {L} {V : option Type@{U}} {R}
+             (r : record (pm_Branch L V R)) : record L :=
+    match r in record z
+          return match z with
+                 | pm_Branch L _ _ => record L
+                 | _ => unit
+                 end
+    with
+      | pr_Branch _ l _ _ => l
+      | pr_Leaf => tt
+    end.
+Set Printing All.
+  Definition record_at {L} {V : option Type@{U}} {R} (r : record (pm_Branch L V R))
+  : match V return Type@{U} with
+    | None => unit
+    | Some t => t
+    end :=
+    match r in record z
+          return match z (* return ?X *) with
+                 | pm_Branch _ V _ => match V return Type@{U} with
+                                     | None => unit
+                                     | Some t => t
+                                     end
+                 | _ => unit
+                 end
+    with
+      | pr_Branch _ _ v _ => v
+      | pr_Leaf => tt
+    end.
+
+  Definition record_here {L : fields} (v : Type@{U}) {R : fields}
+             (r : record (pm_Branch L (@Some Type@{U} v) R)) : v :=
+    match r in record z
+          return match z return Type@{U} with
+                 | pm_Branch _ (Some v) _ => v
+                 | _ => unit
+                 end
+    with
+      | pr_Branch _ _ v _ => v
+      | pr_Leaf => tt
+    end.
+
+  Definition record_right {L V R} (r : record (pm_Branch L V R)) : record R :=
+    match r in record z return match z with
+                                  | pm_Branch _ _ R => record R
+                                  | _ => unit
+                                end
+    with
+      | pr_Branch _ _ _ r => r
+      | pr_Leaf => tt
+    end.
+
+  Fixpoint record_get {val : Type@{U}} {pm : fields} (m : member val pm) : record pm -> val :=
+    match m in member _ pm return record pm -> val with
+      | pmm_H => fun r => record_here r
+      | pmm_L m' => fun r => record_get m' (record_left r)
+      | pmm_R m' => fun r => record_get m' (record_right r)
+    end.
+
+  Fixpoint record_set {val : Type@{U}} {pm : fields} (m : member val pm) (x : val) {struct m}
+  : record pm -> record pm :=
+    match m in member _ pm return record pm -> record pm with
+    | pmm_H => fun r =>
+      pr_Branch (Some _)
+                (record_left r)
+                x
+                (record_right r)
+    | pmm_L m' => fun r =>
+      pr_Branch _
+                (record_set m' x (record_left r))
+                (record_at r)
+                (record_right r)
+    | pmm_R m' => fun r =>
+      pr_Branch _ (record_left r)
+                (record_at r)
+                (record_set m' x (record_right r))
+    end.
+End poly.
+Axiom cheat : forall {A}, A.
+Lemma record_get_record_set_different:
+  forall (T: Type) (vars: fields)
+    (pmr pmw: member T vars)
+    (diff: pmr <> pmw)
+    (r: record vars) (val: T),
+    record_get pmr (record_set pmw val r) = record_get pmr r.
+Proof.
+  intros.
+  revert pmr diff r val.
+  induction pmw; simpl; intros.
+  - dependent destruction pmr.
+    + congruence.
+    + auto.
+    + auto.
+  - dependent destruction pmr.
+    + auto.
+    + simpl. apply IHpmw. congruence.
+    + auto.
+  - dependent destruction pmr.
+    + auto.
+    + auto.
+    + simpl. apply IHpmw. congruence.
+Qed.
diff --git a/test-suite/bugs/closed/HoTT_coq_002.v b/test-suite/bugs/closed/HoTT_coq_002.v
index ba69f6b1..dba4d599 100644
--- a/test-suite/bugs/closed/HoTT_coq_002.v
+++ b/test-suite/bugs/closed/HoTT_coq_002.v
@@ -9,7 +9,7 @@ Section SpecializedFunctor.
   (* Variable objC : Type. *)
   Context `(C : SpecializedCategory objC).
 
-  Polymorphic Record SpecializedFunctor := {
+  Record SpecializedFunctor := {
     ObjectOf' : objC -> Type;
     ObjectC : Object C
   }.
diff --git a/test-suite/bugs/closed/HoTT_coq_020.v b/test-suite/bugs/closed/HoTT_coq_020.v
index 4938b80f..73da464b 100644
--- a/test-suite/bugs/closed/HoTT_coq_020.v
+++ b/test-suite/bugs/closed/HoTT_coq_020.v
@@ -22,8 +22,8 @@ Polymorphic Record NaturalTransformation objC C objD D (F G : Functor (objC := o
 
 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 *
+           | [ _ : context[from ?obj ?C] |- _ ] => progress change (from obj C) with (to obj C) in *
+           | [ |- context[from ?obj ?C] ] => progress change (from obj C) with (to obj C) in *
          end.
 
 Section NaturalTransformationComposition.
@@ -59,8 +59,8 @@ 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.
+  Polymorphic Variable objC : Type.
+  Polymorphic Variable C : Category objC.
 
   Set Printing All.
   Set Printing Universes.
diff --git a/test-suite/bugs/closed/HoTT_coq_047.v b/test-suite/bugs/closed/HoTT_coq_047.v
index 29496be5..bef3c33c 100644
--- a/test-suite/bugs/closed/HoTT_coq_047.v
+++ b/test-suite/bugs/closed/HoTT_coq_047.v
@@ -1,3 +1,5 @@
+Unset Structural Injection.
+
 Inductive nCk : nat -> nat -> Type :=
   |zz : nCk 0 0
   | incl { m n : nat } : nCk m n -> nCk (S m) (S n)
diff --git a/test-suite/bugs/closed/HoTT_coq_058.v b/test-suite/bugs/closed/HoTT_coq_058.v
index 5e5d5ab3..3d16e7ac 100644
--- a/test-suite/bugs/closed/HoTT_coq_058.v
+++ b/test-suite/bugs/closed/HoTT_coq_058.v
@@ -95,10 +95,10 @@ Goal forall (T : Type) (T0 : T -> T -> Type)
                            | 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 F := match goal with |- context[@transport _ (fun x0 => @?F x0) _ _ (@path_forall ?H ?X ?T ?f ?g ?e)] => constr:(F) end in
+let H := match goal with |- context[@transport _ (fun x0 => @?F x0) _ _ (@path_forall ?H ?X ?T ?f ?g ?e)] => constr:(H) end in
+let X := match goal with |- context[@transport _ (fun x0 => @?F x0) _ _ (@path_forall ?H ?X ?T ?f ?g ?e)] => constr:(X) end in
+let T := match goal with |- context[@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
@@ -116,7 +116,7 @@ let T1 := lazymatch type of F with (?T -> _) -> _ => constr:(T) end in
               let GL1' := fresh in
               set (GL0' := GL0);
 
-                let arg := match GL0 with appcontext[x0 ?arg] => constr:(arg) end in
+                let arg := match GL0 with context[x0 ?arg] => constr:(arg) end in
                 assert (t1 = arg) by (subst t1; reflexivity); subst t1;
                 pattern (x0 arg) in GL0';
                 match goal with
diff --git a/test-suite/bugs/closed/HoTT_coq_117.v b/test-suite/bugs/closed/HoTT_coq_117.v
index 5fbcfef4..de60fd0a 100644
--- a/test-suite/bugs/closed/HoTT_coq_117.v
+++ b/test-suite/bugs/closed/HoTT_coq_117.v
@@ -16,10 +16,29 @@ Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A,
 Admitted.
 
 Inductive Empty : Set := .
-Instance contr_from_Empty {_ : Funext} (A : Type) :
+Fail 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)).
+
+Fail Instance contr_from_Empty {F : Funext} (A : Type) :
   Contr_internal (Empty -> A) :=
   BuildContr _
              (Empty_rect (fun _ => A))
              (fun f => path_forall _ f (fun x => Empty_rect _ x)).
+
+(** This could be disallowed, this uses the Funext argument *)
+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 (fun _ => _ x = f x) x)).
+
+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 (fun _ => _ x = f x) x)).
 (* Toplevel input, characters 15-220:
 Anomaly: unknown meta ?190. Please report. *)
diff --git a/test-suite/bugs/closed/PLACEHOLDER.v b/test-suite/bugs/closed/PLACEHOLDER.v
new file mode 100644
index 00000000..e69de29b
--- /dev/null
+++ b/test-suite/bugs/closed/PLACEHOLDER.v
diff --git a/test-suite/bugs/closed/bug_4836.v b/test-suite/bugs/closed/bug_4836.v
new file mode 100644
index 00000000..5838dcd8
--- /dev/null
+++ b/test-suite/bugs/closed/bug_4836.v
@@ -0,0 +1 @@
+(* -*- coq-prog-args: ("-compile" "bugs/closed/PLACEHOLDER.v") -*- *)
diff --git a/test-suite/bugs/closed/bug_4836/PLACEHOLDER b/test-suite/bugs/closed/bug_4836/PLACEHOLDER
new file mode 100644
index 00000000..e69de29b
--- /dev/null
+++ b/test-suite/bugs/closed/bug_4836/PLACEHOLDER
diff --git a/test-suite/bugs/opened/3383.v b/test-suite/bugs/opened/3383.v
deleted file mode 100644
index 9a14641a..00000000
--- a/test-suite/bugs/opened/3383.v
+++ /dev/null
@@ -1,7 +0,0 @@
-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/3410.v b/test-suite/bugs/opened/3410.v
deleted file mode 100644
index 0d259181..00000000
--- a/test-suite/bugs/opened/3410.v
+++ /dev/null
@@ -1 +0,0 @@
-Fail repeat match goal with H:_ |- _ => setoid_rewrite X in H end.
diff --git a/test-suite/bugs/opened/3889.v b/test-suite/bugs/opened/3889.v
new file mode 100644
index 00000000..6b287324
--- /dev/null
+++ b/test-suite/bugs/opened/3889.v
@@ -0,0 +1,11 @@
+Require Import Program.
+
+Inductive Even : nat -> Prop :=
+| evenO : Even O
+| evenS : forall n, Odd n -> Even (S n)
+with Odd : nat -> Prop :=
+| oddS : forall n, Even n -> Odd (S n).
+Axiom admit : forall {T}, T.
+Program Fixpoint doubleE {n} (e : Even n) : Even (2 * n) := admit
+with doubleO {n} (o : Odd n) : Odd (S (2 * n)) := _.
+Next Obligation of doubleE.
diff --git a/test-suite/bugs/opened/3890.v b/test-suite/bugs/opened/3890.v
new file mode 100644
index 00000000..f9ac9be2
--- /dev/null
+++ b/test-suite/bugs/opened/3890.v
@@ -0,0 +1,18 @@
+Class Foo.
+Class Bar := b : Type.
+
+Instance foo : Foo := _.
+(* 1 subgoals, subgoal 1 (ID 4)
+  
+  ============================
+   Foo *)
+
+Instance bar : Bar.
+exact Type.
+Defined.
+(* bar is defined *)
+
+About foo.
+(* foo not a defined object. *)
+
+Fail Defined.
diff --git a/test-suite/bugs/opened/3916.v b/test-suite/bugs/opened/3916.v
new file mode 100644
index 00000000..fd95503e
--- /dev/null
+++ b/test-suite/bugs/opened/3916.v
@@ -0,0 +1,3 @@
+Require Import List.
+
+Fail Hint Resolve -> in_map. (* Also happens when using <- instead of -> *)
diff --git a/test-suite/bugs/opened/3919.v-disabled b/test-suite/bugs/opened/3919.v-disabled
new file mode 100644
index 00000000..0d661de9
--- /dev/null
+++ b/test-suite/bugs/opened/3919.v-disabled
@@ -0,0 +1,13 @@
+Require Import MSets.
+Require Import Orders.
+
+Declare Module Signal : OrderedType.
+
+Module S := MSetAVL.Make(Signal).
+Module Sdec := Decide(S).
+Export Sdec.
+
+Hint Extern 0 (Signal.eq ?x ?y) => now symmetry.
+
+Goal forall o s, Signal.eq o s.
+Proof. fsetdec. Qed.
diff --git a/test-suite/bugs/opened/3922.v-disabled b/test-suite/bugs/opened/3922.v-disabled
new file mode 100644
index 00000000..ce4f509c
--- /dev/null
+++ b/test-suite/bugs/opened/3922.v-disabled
@@ -0,0 +1,83 @@
+Set Universe Polymorphism.
+Notation Type0 := Set.
+
+Definition Type1 := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}.
+
+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 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.
+
+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 Contr := (IsTrunc -2).
+Notation IsHProp := (IsTrunc -1).
+
+Monomorphic Axiom dummy_funext_type : Type0.
+Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }.
+
+Inductive Unit : Type1 :=
+    tt : Unit.
+
+Record TruncType (n : trunc_index) := BuildTruncType {
+  trunctype_type : Type ;
+  istrunc_trunctype_type : IsTrunc n trunctype_type
+}.
+
+Arguments BuildTruncType _ _ {_}.
+
+Coercion trunctype_type : TruncType >-> Sortclass.
+
+Notation "n -Type" := (TruncType n) (at level 1) : type_scope.
+Notation hProp := (-1)-Type.
+
+Notation BuildhProp := (BuildTruncType -1).
+
+Private Inductive Trunc (n : trunc_index) (A :Type) : Type :=
+  tr : A -> Trunc n A.
+Arguments tr {n A} a.
+
+Global Instance istrunc_truncation (n : trunc_index) (A : Type@{i})
+: IsTrunc@{j} n (Trunc@{i} n A).
+Admitted.
+
+Definition Trunc_ind {n A}
+  (P : Trunc n A -> Type) {Pt : forall aa, IsTrunc n (P aa)}
+  : (forall a, P (tr a)) -> (forall aa, P aa)
+:= (fun f aa => match aa with tr a => fun _ => f a end Pt).
+Definition merely (A : Type@{i}) : hProp@{i} := BuildhProp (Trunc -1 A).
+Definition cconst_factors_contr `{Funext}  {X Y : Type} (f : X -> Y)
+           (P : Type) `{Pc : X -> Contr P}
+           (g : X -> P) (h : P -> Y) (p : h o g == f)
+: Unit.
+Proof.
+  assert (merely X -> IsHProp P) by admit.
+  refine (let g' := Trunc_ind (fun _ => P) g : merely X -> P in _);
+    [ assumption.. | ].
+  Fail pose (g' := Trunc_ind (fun _ => P) g : merely X -> P).
diff --git a/test-suite/bugs/opened/3926.v b/test-suite/bugs/opened/3926.v
new file mode 100644
index 00000000..cfad7635
--- /dev/null
+++ b/test-suite/bugs/opened/3926.v
@@ -0,0 +1,30 @@
+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.
+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.
+Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A }.
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope.
+Local Open Scope equiv_scope.
+Axiom eisretr : forall {A B} (f : A -> B) `{IsEquiv A B f} x, f (f^-1 x) = x.
+Generalizable Variables A B C f g.
+Global Instance isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g} : IsEquiv (compose g f) | 1000
+  := Build_IsEquiv A C (compose g f) (compose f^-1 g^-1).
+Definition isequiv_homotopic {A B} (f : A -> B) {g : A -> B} `{IsEquiv A B f} (h : forall x, f x = g x) : IsEquiv g
+  := Build_IsEquiv _ _ g (f ^-1).
+Global Instance isequiv_inverse {A B} (f : A -> B) `{IsEquiv A B f} : IsEquiv f^-1 | 10000
+  := Build_IsEquiv B A f^-1 f.
+Definition cancelR_isequiv {A B C} (f : A -> B) {g : B -> C}
+  `{IsEquiv A B f} `{IsEquiv A C (g o f)}
+  : IsEquiv g.
+Proof.
+  Unset Typeclasses Modulo Eta.
+  exact (isequiv_homotopic (compose (compose g f) f^-1)
+                           (fun b => ap g (eisretr f b))) || fail "too early".
+  Undo.
+  Set Typeclasses Modulo Eta.
+  Set Typeclasses Dependency Order.
+  Set Typeclasses Debug.
+  Fail exact (isequiv_homotopic (compose (compose g f) f^-1)
+                           (fun b => ap g (eisretr f b))).
diff --git a/test-suite/bugs/opened/3928.v-disabled b/test-suite/bugs/opened/3928.v-disabled
new file mode 100644
index 00000000..b470eb22
--- /dev/null
+++ b/test-suite/bugs/opened/3928.v-disabled
@@ -0,0 +1,12 @@
+Typeclasses eauto := bfs.
+
+Class Foo := {}.
+Class Bar := {}.
+
+Instance: Bar.
+Instance: Foo -> Bar -> Foo -> Foo | 1.
+Instance: Bar -> Foo | 100.
+Instance: Foo -> Bar -> Foo -> Foo | 1.
+
+Set Typeclasses Debug.
+Timeout 1 Check (_ : Foo). (* timeout *)
diff --git a/test-suite/bugs/opened/3938.v b/test-suite/bugs/opened/3938.v
new file mode 100644
index 00000000..2d0d1930
--- /dev/null
+++ b/test-suite/bugs/opened/3938.v
@@ -0,0 +1,6 @@
+Require Import Coq.Arith.PeanoNat.
+Hint Extern 1 => admit : typeclass_instances.
+Goal forall a b (f : nat -> Set), Nat.eq a b -> f a = f b.
+  intros a b f H.
+  rewrite H. (* Toplevel input, characters 15-25:
+Anomaly: Evar ?X11 was not declared. Please report. *)
diff --git a/test-suite/bugs/opened/3946.v b/test-suite/bugs/opened/3946.v
new file mode 100644
index 00000000..e77bdbc6
--- /dev/null
+++ b/test-suite/bugs/opened/3946.v
@@ -0,0 +1,11 @@
+Require Import ZArith.
+
+Inductive foo := Foo : Z.le 0 1 -> foo.
+
+Definition bar (f : foo) := let (f) := f in f.
+
+(* Doesn't work: *)
+(* Arguments bar f.*)
+
+(* Does work *)
+Arguments bar f _.
diff --git a/test-suite/bugs/opened/3948.v b/test-suite/bugs/opened/3948.v
new file mode 100644
index 00000000..16581308
--- /dev/null
+++ b/test-suite/bugs/opened/3948.v
@@ -0,0 +1,25 @@
+Module Type S.
+Parameter t : Type.
+End S.
+
+Module Bar(X : S).
+Proof.
+  Definition elt := X.t.
+  Axiom fold : elt.
+End Bar.
+
+Module Make (X: S) := Bar(X).
+
+Declare Module X : S.
+
+Module Type Interface.
+  Parameter constant : unit.
+End Interface.
+
+Module DepMap : Interface.
+  Module Dom := Make(X).
+  Definition constant : unit :=
+    let _ := @Dom.fold in tt.
+End DepMap.
+
+Print Assumptions DepMap.constant.
\ No newline at end of file
diff --git a/test-suite/bugs/opened/4701.v b/test-suite/bugs/opened/4701.v
new file mode 100644
index 00000000..9286f0f1
--- /dev/null
+++ b/test-suite/bugs/opened/4701.v
@@ -0,0 +1,23 @@
+(*Suppose we have*)
+
+  Inductive my_if {A B} : bool -> Type :=
+  | then_case (_ : A) : my_if true
+  | else_case (_ : B) : my_if false.
+  Notation "'If' b 'Then' A 'Else' B" := (@my_if A B b) (at level 10).
+
+(*then here are three inductive type declarations that work:*)
+
+  Inductive I1 :=
+  | i1 (x : I1).
+  Inductive I2 :=
+  | i2 (x : nat).
+  Inductive I3 :=
+  | i3 (b : bool) (x : If b Then I3 Else nat).
+
+(*and here is one that does not, despite being equivalent to [I3]:*)
+
+  Fail Inductive I4 :=
+  | i4 (b : bool) (x : if b then I4 else nat). (* Error: Non strictly positive occurrence of "I4" in
+   "forall b : bool, (if b then I4 else nat) -> I4". *)
+
+(*I think this one should work.  I believe this is a conservative extension over CIC: Since [match] statements returning types can always be re-encoded as inductive type families, the analysis should be independent of whether the constructor uses an inductive or a [match] statement.*)
diff --git a/test-suite/bugs/opened/4717.v b/test-suite/bugs/opened/4717.v
new file mode 100644
index 00000000..9ad47467
--- /dev/null
+++ b/test-suite/bugs/opened/4717.v
@@ -0,0 +1,19 @@
+(*See below. They sometimes work, and sometimes do not. Is this a bug?*)
+
+Require Import Omega Psatz.
+
+Definition foo := nat.
+
+Goal forall (n : foo), 0 = n - n.
+Proof. intros. omega. (* works *) Qed.
+
+Goal forall (x n : foo), x = x + n - n.
+Proof.
+  intros.
+  Fail omega. (* Omega can't solve this system *)
+  Fail lia. (* Cannot find witness. *)
+  unfold foo in *.
+  omega. (* works *)
+Qed.
+
+(* Guillaume Melquiond: What matters is the equality. In the first case, it is @eq nat. In the second case, it is @eq foo. The same issue exists for ring and field. So it is not a bug, but it is worth fixing.*)
diff --git a/test-suite/bugs/opened/4721.v b/test-suite/bugs/opened/4721.v
new file mode 100644
index 00000000..1f184b39
--- /dev/null
+++ b/test-suite/bugs/opened/4721.v
@@ -0,0 +1,13 @@
+Variables S1 S2 : Set.
+
+Goal @eq Type S1 S2 -> @eq Type S1 S2.
+intro H.
+Fail tauto.
+assumption.
+Qed.
+
+(*This is in 8.5pl1, and Matthieq Sozeau says: "That's a regression in tauto indeed, which now requires exact equality of the universes, through a non linear goal pattern matching:
+match goal with ?X1 |- ?X1 forces both instances of X1 to be convertible,
+with no additional universe constraints currently, but the two types are
+initially different. This can be fixed easily to allow the same flexibility
+as in 8.4 (or assumption) to unify the universes as well."*)
diff --git a/test-suite/bugs/opened/4728.v b/test-suite/bugs/opened/4728.v
new file mode 100644
index 00000000..230b4beb
--- /dev/null
+++ b/test-suite/bugs/opened/4728.v
@@ -0,0 +1,72 @@
+(*I'd like the final [Check] in the following to work:*)
+
+Ltac fin_eta_expand :=
+  [ > lazymatch goal with
+      | [ H : _ |- _ ] => clear H
+      end..
+  | lazymatch goal with
+    | [ H : ?T |- ?T ]
+      => exact H
+    | [ |- ?G ]
+      => fail 0 "No hypothesis matching" G
+    end ];
+  let n := numgoals in
+  tryif constr_eq numgoals 0
+  then idtac
+  else fin_eta_expand.
+
+Ltac pre_eta_expand x :=
+  let T := type of x in
+  let G := match goal with |- ?G => G end in
+  unify T G;
+  unshelve econstructor;
+  destruct x;
+  fin_eta_expand.
+
+Ltac eta_expand x :=
+  let v := constr:(ltac:(pre_eta_expand x)) in
+  idtac v;
+  let v := (eval cbv beta iota zeta in v) in
+  exact v.
+
+Notation eta_expand x := (ltac:(eta_expand x)) (only parsing).
+
+Ltac partial_unify eqn :=
+  lazymatch eqn with
+  | ?x = ?x => idtac
+  | ?f ?x = ?g ?y
+    => partial_unify (f = g);
+       (tryif unify x y then
+           idtac
+         else tryif has_evar x then
+             unify x y
+           else tryif has_evar y then
+               unify x y
+             else
+               idtac)
+  | ?x = ?y
+    => idtac;
+       (tryif unify x y then
+           idtac
+         else tryif has_evar x then
+             unify x y
+           else tryif has_evar y then
+               unify x y
+             else
+               idtac)
+  end.
+
+Tactic Notation "{" open_constr(old_record) "with" open_constr(new_record) "}" :=
+  let old_record' := eta_expand old_record in
+  partial_unify (old_record = new_record);
+  eexact new_record.
+
+Set Implicit Arguments.
+Record prod A B := pair { fst : A ; snd : B }.
+Infix "*" := prod : type_scope.
+Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
+
+Notation "{ old 'with' new }" := (ltac:({ old with new })) (only parsing).
+
+Check ltac:({ (1, 1) with {| snd := 2 |} }).
+Fail Check { (1, 1) with {| snd := 2 |} }. (* Error: Cannot infer this placeholder of type "Type"; should succeed *)
diff --git a/test-suite/bugs/opened/4755.v b/test-suite/bugs/opened/4755.v
new file mode 100644
index 00000000..9cc0d361
--- /dev/null
+++ b/test-suite/bugs/opened/4755.v
@@ -0,0 +1,34 @@
+(*I'm not sure which behavior is better.  But if the change is intentional, it should be documented (I don't think it is), and it'd be nice if there were a flag for this, or if -compat 8.4 restored the old behavior.*)
+
+Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms.
+Definition f (v : option nat) := match v with
+                                 | Some k => Some k
+                                 | None => None
+                                 end.
+
+Axioms F G : (option nat -> option nat) -> Prop.
+Axiom FG : forall f, f None = None -> F f = G f.
+
+Axiom admit : forall {T}, T.
+
+Existing Instance eq_Reflexive.
+
+Global Instance foo (A := nat)
+  : Proper ((pointwise_relation _ eq)
+              ==> eq ==> forall_relation (fun _ => Basics.flip Basics.impl))
+           (@option_rect A (fun _ => Prop)) | 0.
+exact admit.
+Qed.
+
+Global Instance bar (A := nat)
+  : Proper ((pointwise_relation _ eq)
+              ==> eq ==> eq ==> Basics.flip Basics.impl)
+           (@option_rect A (fun _ => Prop)) | 0.
+exact admit.
+Qed.
+
+Goal forall k, option_rect (fun _ => Prop) (fun v : nat => v = v /\ F f) True k.
+Proof.
+  intro.
+  pose proof (_ : (Proper (_ ==> eq ==> _) and)).
+  Fail setoid_rewrite (FG _ _); []. (* In 8.5: Error: Tactic failure: Incorrect number of goals (expected 2 tactics); works in 8.4 *)
diff --git a/test-suite/bugs/opened/4771.v b/test-suite/bugs/opened/4771.v
new file mode 100644
index 00000000..396d74bd
--- /dev/null
+++ b/test-suite/bugs/opened/4771.v
@@ -0,0 +1,22 @@
+Module Type Foo.
+
+Parameter Inline t : nat.
+
+End Foo.
+
+Module F(X : Foo).
+
+Tactic Notation "foo" ref(x) := idtac.
+
+Ltac g := foo X.t.
+
+End F.
+
+Module N.
+Definition t := 0 + 0.
+End N.
+
+Module K := F(N).
+
+(* Was
+Anomaly: Uncaught exception Not_found. Please report. *)
diff --git a/test-suite/bugs/opened/4778.v b/test-suite/bugs/opened/4778.v
new file mode 100644
index 00000000..633d158e
--- /dev/null
+++ b/test-suite/bugs/opened/4778.v
@@ -0,0 +1,35 @@
+Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms.
+Definition f (v : option nat) := match v with
+                                 | Some k => Some k
+                                 | None => None
+                                 end.
+
+Axioms F G : (option nat -> option nat) -> Prop.
+Axiom FG : forall f, f None = None -> F f = G f.
+
+Axiom admit : forall {T}, T.
+
+Existing Instance eq_Reflexive.
+
+(* This instance is needed in 8.4, but is useless in 8.5 *)
+Global Instance foo (A := nat)
+  : Proper ((pointwise_relation _ eq)
+              ==> eq ==> forall_relation (fun _ => Basics.flip Basics.impl))
+           (@option_rect A (fun _ => Prop)) | 0.
+exact admit.
+Qed.
+
+(*
+(* This is required in 8.5, but useless in 8.4 *)
+Global Instance bar (A := nat)
+  : Proper ((pointwise_relation _ eq)
+              ==> eq ==> eq ==> Basics.flip Basics.impl)
+           (@option_rect A (fun _ => Prop)) | 0.
+exact admit.
+Qed.
+*)
+
+Goal forall k, option_rect (fun _ => Prop) (fun v : nat => v = v /\ F f) True k. Proof.
+  intro.
+  pose proof (_ : (Proper (_ ==> eq ==> _) and)).
+  Fail setoid_rewrite (FG _ _); [ | reflexivity.. ]. (* this should succeed without [Fail], as it does in 8.4 *)
diff --git a/test-suite/bugs/opened/4781.v b/test-suite/bugs/opened/4781.v
new file mode 100644
index 00000000..8b651ac2
--- /dev/null
+++ b/test-suite/bugs/opened/4781.v
@@ -0,0 +1,94 @@
+Ltac force_clear :=
+  clear;
+  repeat match goal with
+         | [ H : _ |- _ ] => clear H
+         | [ H := _ |- _ ] => clearbody H
+         end.
+
+Class abstract_term {T} (x : T) := by_abstract_term : T.
+Hint Extern 0 (@abstract_term ?T ?x) => force_clear; change T; abstract (exact x) : typeclass_instances.
+
+Goal True.
+(* These work: *)
+  let term := constr:(I) in
+  let T := type of term in
+  let x := constr:((_ : abstract_term term) : T) in
+  pose x.
+  let term := constr:(I) in
+  let T := type of term in
+  let x := constr:((_ : abstract_term term) : T) in
+  let x := (eval cbv iota in (let v : T := x in v)) in
+  pose x.
+  let term := constr:(I) in
+  let T := type of term in
+  let x := constr:((_ : abstract_term term) : T) in
+  let x := match constr:(Set) with ?y => constr:(y) end in
+  pose x.
+(* This fails with an error: *)
+  Fail let term := constr:(I) in
+  let T := type of term in
+  let x := constr:((_ : abstract_term term) : T) in
+  let x := match constr:(x) with ?y => constr:(y) end in
+  pose x. (* The command has indeed failed with message:
+Error: Variable y should be bound to a term. *)
+(* And the rest fail with Anomaly: Uncaught exception Not_found. Please report. *)
+  Fail let term := constr:(I) in
+  let T := type of term in
+  let x := constr:((_ : abstract_term term) : T) in
+  let x := match constr:(x) with ?y => y end in
+  pose x.
+  Fail let term := constr:(I) in
+  let T := type of term in
+  let x := constr:((_ : abstract_term term) : T) in
+  let x := (eval cbv iota in x) in
+  pose x.
+  Fail let term := constr:(I) in
+  let T := type of term in
+  let x := constr:((_ : abstract_term term) : T) in
+  let x := type of x in
+  pose x. (* should succeed *)
+  Fail let term := constr:(I) in
+  let T := type of term in
+  let x := constr:(_ : abstract_term term) in
+  let x := type of x in
+  pose x. (* should succeed *)
+
+(*Apparently what [cbv iota] doesn't see can't hurt it, and [pose] is perfectly happy with abstracted lemmas only some of the time.
+
+Even stranger, consider:*)
+  let term := constr:(I) in
+  let T := type of term in
+  let x := constr:((_ : abstract_term term) : T) in
+  let y := (eval cbv iota in (let v : T := x in v)) in
+  pose y;
+    let x' := fresh "x'" in
+    pose x as x'.
+      let x := (eval cbv delta [x'] in x') in
+      pose x;
+      let z := (eval cbv iota in x) in
+      pose z.
+
+(*This works fine.  But if I change the period to a semicolon, I get:*)
+
+      Fail let term := constr:(I) in
+  let T := type of term in
+  let x := constr:((_ : abstract_term term) : T) in
+  let y := (eval cbv iota in (let v : T := x in v)) in
+  pose y;
+    let x' := fresh "x'" in
+    pose x as x';
+      let x := (eval cbv delta [x'] in x') in
+      pose x. (* Anomaly: Uncaught exception Not_found. Please report. *)
+ (* should succeed *)
+(*and if I use the second one instead of [pose x] (note that using [idtac] works fine), I get:*)
+
+ Fail  let term := constr:(I) in
+  let T := type of term in
+  let x := constr:((_ : abstract_term term) : T) in
+  let y := (eval cbv iota in (let v : T := x in v)) in
+  pose y;
+    let x' := fresh "x'" in
+    pose x as x';
+      let x := (eval cbv delta [x'] in x') in
+      let z := (eval cbv iota in x) in (* Error: Variable x should be bound to a term. *)
+      idtac. (* should succeed *)
diff --git a/test-suite/bugs/opened/4803.v b/test-suite/bugs/opened/4803.v
new file mode 100644
index 00000000..4530548b
--- /dev/null
+++ b/test-suite/bugs/opened/4803.v
@@ -0,0 +1,48 @@
+(* -*- coq-prog-args: ("-emacs" "-compat" "8.4") -*- *)
+(*Suppose a user wants to declare a new list-like notation with support for singletons in both 8.4 and 8.5.  If they use*)
+Require Import Coq.Lists.List.
+Require Import Coq.Vectors.Vector.
+Import ListNotations.
+Import VectorNotations.
+Set Implicit Arguments.
+Inductive mylist T := mynil | mycons (_ : T) (_ : mylist T).
+Arguments mynil {_}, _.
+
+Delimit Scope mylist_scope with mylist.
+Bind Scope mylist_scope with mylist.
+Delimit Scope vector_scope with vector.
+
+Notation " [ ] " := mynil (format "[ ]") : mylist_scope.
+Notation " [ x ] " := (mycons x mynil) : mylist_scope.
+Notation " [ x ; .. ; y ] " := (mycons x .. (mycons y mynil) ..) : mylist_scope.
+
+(** All of these should work fine in -compat 8.4 mode, just as they do in Coq 8.4.  There needs to be a way to specify notations above so that all of these [Check]s go through in both 8.4 and 8.5 *)
+Check [ ]%mylist : mylist _.
+Check [ ]%list : list _.
+Check []%vector : Vector.t _ _.
+Check [ _ ]%mylist : mylist _.
+Check [ _ ]%list : list _.
+Check [ _ ]%vector : Vector.t _ _.
+Check [ _ ; _ ]%list : list _.
+Check [ _ ; _ ]%vector : Vector.t _ _.
+Check [ _ ; _ ]%mylist : mylist _.
+Check [ _ ; _ ; _ ]%list : list _.
+Check [ _ ; _ ; _ ]%vector : Vector.t _ _.
+Check [ _ ; _ ; _ ]%mylist : mylist _.
+Check [ _ ; _ ; _ ; _ ]%list : list _.
+Check [ _ ; _ ; _ ; _ ]%vector : Vector.t _ _.
+Check [ _ ; _ ; _ ; _ ]%mylist : mylist _.
+
+(** Now check that we can add and then remove notations from the parser *)
+(* We should be able to stick some vernacular here to remove [] from the parser *)
+Fail Remove Notation "[]".
+Goal True.
+  (* This should not be a syntax error; before moving this file to closed, uncomment this line. *)
+  (* idtac; []. *)
+  constructor.
+Qed.
+
+Check { _ : _ & _ }.
+Reserved Infix "&" (at level 0).
+Fail Remove Infix "&".
+(* Check { _ : _ & _ }. *)
diff --git a/test-suite/bugs/opened/4813.v b/test-suite/bugs/opened/4813.v
new file mode 100644
index 00000000..b7517017
--- /dev/null
+++ b/test-suite/bugs/opened/4813.v
@@ -0,0 +1,5 @@
+(* An example one would like to see succeeding *)
+
+Record T := BT { t : Set }.
+Record U (x : T) := BU { u : t x -> Prop }.
+Fail Definition A (H : unit -> Prop) : U (BT unit) := BU _ H.
diff --git a/test-suite/complexity/ring2.v b/test-suite/complexity/ring2.v
index 52dae265..04fa5907 100644
--- a/test-suite/complexity/ring2.v
+++ b/test-suite/complexity/ring2.v
@@ -39,7 +39,7 @@ Admitted.
 Ltac Zcst t :=
   match isZcst t with
     true => t
-  | _ => constr:NotConstant
+  | _ => constr:(NotConstant)
   end.
 
 Add Ring Zr : Zth
diff --git a/test-suite/csdp.cache b/test-suite/csdp.cache
deleted file mode 100644
index 297ac255..00000000
--- a/test-suite/csdp.cache
+++ /dev/null
diff --git a/test-suite/failure/int31.v b/test-suite/failure/int31.v
new file mode 100644
index 00000000..b1d11224
--- /dev/null
+++ b/test-suite/failure/int31.v
@@ -0,0 +1,17 @@
+Require Import Int31 BigN.
+
+Open Scope int31_scope.
+
+(* This used to go through because of an unbalanced stack bug in the bytecode
+interpreter *)
+
+Lemma bad : False.
+assert (1 = 2).
+change 1 with (add31 (addmuldiv31 65 (add31 1 1) 2) 1).
+Fail vm_compute; reflexivity.
+(*
+discriminate.
+Qed.
+*)
+Abort.
+
diff --git a/test-suite/failure/positivity.v b/test-suite/failure/positivity.v
index 91de8733..8089de2b 100644
--- a/test-suite/failure/positivity.v
+++ b/test-suite/failure/positivity.v
@@ -5,5 +5,47 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-Fail Inductive t : Set :=
-    c : (t -> nat) -> t.
+
+(* Negative occurrence *)
+Fail Inductive t : Type :=
+  c : (t -> nat) -> t.
+
+(* Non-strictely positive occurrence *)
+Fail Inductive t : Type :=
+  c : ((t -> nat) -> nat) -> t.
+
+(* Self-nested type (no proof of
+   soundness yet *)
+Fail Inductive t (A:Type) : Type :=
+  c : t (t A) -> t A.
+
+(* Nested inductive types *)
+
+Inductive pos (A:Type) :=
+  p : pos A -> pos A.
+
+Inductive nnpos (A:Type) :=
+  nnp : ((A -> nat) -> nat) -> nnpos A.
+
+Inductive neg (A:Type) :=
+  n : (A->neg A) -> neg A.
+
+Inductive arg : Type -> Prop :=
+  a : forall A, arg A -> arg A.
+
+(* Strictly covariant parameter: accepted. *)
+Fail Fail Inductive t :=
+  c : pos t -> t.
+
+(* Non-strictly covariant parameter: not
+   strictly positive. *)
+Fail Inductive t :=
+  c : nnpos t -> t.
+
+(* Contravariant parameter: not positive. *)
+Fail Inductive t :=
+  c : neg t -> t.
+
+(* Strict index: not positive. *)
+Fail Inductive t :=
+  c : arg t -> t.
diff --git a/test-suite/ide/undo013.fake b/test-suite/ide/undo013.fake
index f44156aa..921a9d0f 100644
--- a/test-suite/ide/undo013.fake
+++ b/test-suite/ide/undo013.fake
@@ -23,5 +23,5 @@ ADD { Qed. }
 ADD { apply H. }
 # </replay>
 ADD { Qed. }
-QUERY { Fail idtac. }
+QUERY { Fail Show. }
 QUERY { Check (aa,bb,cc). }
diff --git a/test-suite/ide/undo014.fake b/test-suite/ide/undo014.fake
index 6d58b061..f5fe7747 100644
--- a/test-suite/ide/undo014.fake
+++ b/test-suite/ide/undo014.fake
@@ -22,5 +22,5 @@ ADD { destruct H. }
 ADD { Qed. }
 ADD { apply H. }
 ADD { Qed. }
-QUERY { Fail idtac. }
+QUERY { Fail Show. }
 QUERY { Check (aa,bb,cc). }
diff --git a/test-suite/ide/undo015.fake b/test-suite/ide/undo015.fake
index ac17985a..a1e5c947 100644
--- a/test-suite/ide/undo015.fake
+++ b/test-suite/ide/undo015.fake
@@ -25,5 +25,5 @@ ADD { destruct H. }
 ADD { Qed. }
 ADD { apply H. }
 ADD { Qed. }
-QUERY { Fail idtac. }
+QUERY { Fail Show. }
 QUERY { Check (aa,bb,cc). }
diff --git a/test-suite/ide/undo016.fake b/test-suite/ide/undo016.fake
index bdb81ecd..f9414c1e 100644
--- a/test-suite/ide/undo016.fake
+++ b/test-suite/ide/undo016.fake
@@ -27,5 +27,5 @@ ADD { destruct H. }
 ADD { Qed. }
 ADD { apply H. }
 ADD { Qed. }
-QUERY { Fail idtac. }
+QUERY { Fail Show. }
 QUERY { Check (aa,bb,cc). }
diff --git a/test-suite/interactive/proof_block.v b/test-suite/interactive/proof_block.v
new file mode 100644
index 00000000..31e34937
--- /dev/null
+++ b/test-suite/interactive/proof_block.v
@@ -0,0 +1,66 @@
+Goal False /\ True.
+Proof.
+split.
+  idtac.
+  idtac.
+  exact I.
+idtac.
+idtac.
+exact I.
+Qed.
+
+Lemma baz :  (exists n, n = 3 /\ n = 3) /\ True.
+Proof.
+split. { eexists. split. par: trivial. }
+trivial.
+Qed.
+
+Lemma baz1 :  (True /\ False) /\ True.
+Proof.
+split. { split. par: trivial. }
+trivial.
+Qed.
+
+Lemma foo : (exists n, n = 3 /\ n = 3) /\ True.
+Proof.
+split.
+  { idtac.
+    unshelve eexists.
+    { apply 3. }
+    { split.
+      { idtac. trivialx. }
+      { reflexivity. } } }
+  trivial.
+Qed.
+
+Lemma foo1 : False /\ True.
+Proof.
+split.
+  { exact I. }
+  { exact I. }
+Qed.
+
+Definition banana := true + 4. 
+
+Check banana.
+
+Lemma bar : (exists n, n = 3 /\ n = 3) /\ True.
+Proof.
+split.
+  - idtac.
+    unshelve eexists.
+    + apply 3.
+    + split.
+      * idtacx. trivial. 
+      * reflexivity.
+  - trivial.
+Qed.
+
+Lemma baz2 :  ((1=0 /\ False) /\ True) /\ False.
+Proof.
+split. split. split.
+ - solve [ auto ].
+ - solve [ trivial ].
+ - solve [ trivial ].
+ - exact 6.
+Qed.
\ No newline at end of file
diff --git a/test-suite/micromega/bertot.v b/test-suite/micromega/bertot.v
index bcf222f9..29171aed 100644
--- a/test-suite/micromega/bertot.v
+++ b/test-suite/micromega/bertot.v
@@ -11,6 +11,8 @@ Require Import Psatz.
 
 Open Scope Z_scope.
 
+
+
 Goal (forall x y n,
   ( ~ x < n /\ x <= n /\ 2 * y = x*(x+1) -> 2 * y = n*(n+1))
   /\
diff --git a/test-suite/micromega/qexample.v b/test-suite/micromega/qexample.v
index 47e6005b..d001e8f7 100644
--- a/test-suite/micromega/qexample.v
+++ b/test-suite/micromega/qexample.v
@@ -6,32 +6,29 @@
 (*                                                                      *)
 (************************************************************************)
 
-Require Import Psatz.
+Require Import Lqa.
 Require Import QArith.
 
 Lemma plus_minus : forall x y,
   0 == x + y -> 0 ==  x -y -> 0 == x /\ 0 == y.
 Proof.
   intros.
-  psatzl Q.
+  lra.
 Qed.
 
-
-
-
 (* Other (simple) examples *)
 Open Scope Q_scope.
 
 Lemma binomial : forall x y:Q, ((x+y)^2 == x^2 + (2 # 1) *x*y + y^2).
 Proof.
   intros.
-  psatzl Q.
+  lra.
 Qed.
 
 
 Lemma hol_light19 : forall m n, (2 # 1) * m + n == (n + m) + m.
 Proof.
-  intros ; psatzl Q.
+  intros ; lra.
 Qed.
 Open Scope Z_scope.
 Open Scope Q_scope.
@@ -60,7 +57,11 @@ Lemma vcgen_25 : forall
   (( 1# 1) == (-2 # 1) * i + it).
 Proof.
   intros.
-  psatzl Q.
+  lra.
+Qed.
+
+Goal forall x : Q, x * x >= 0.
+  intro; nra. 
 Qed.
 
 Goal forall x, -x^2 >= 0 -> x - 1 >= 0 -> False.
diff --git a/test-suite/micromega/rexample.v b/test-suite/micromega/rexample.v
index 2eed7e95..bd522701 100644
--- a/test-suite/micromega/rexample.v
+++ b/test-suite/micromega/rexample.v
@@ -6,16 +6,22 @@
 (*                                                                      *)
 (************************************************************************)
 
-Require Import Psatz.
+Require Import Lra.
 Require Import Reals.
 
 Open Scope R_scope.
 
+
+Lemma cst_test : 5^5 = 5 * 5 * 5 *5 *5.
+Proof.
+  lra.
+Qed.
+
 Lemma yplus_minus : forall x y,
   0 = x + y -> 0 =  x -y -> 0 = x /\ 0 = y.
 Proof.
   intros.
-  psatzl R.
+  lra.
 Qed.
 
 (* Other (simple) examples *)
@@ -23,13 +29,13 @@ Qed.
 Lemma binomial : forall x y, ((x+y)^2 = x^2 + 2 *x*y + y^2).
 Proof.
   intros.
-  psatzl R.
+  lra.
 Qed.
 
 
 Lemma hol_light19 : forall m n, 2 * m + n = (n + m) + m.
 Proof.
-  intros ; psatzl R.
+  intros ; lra.
 Qed.
 
 
@@ -57,7 +63,7 @@ Lemma vcgen_25 : forall
   (( 1 ) = (-2  ) * i + it).
 Proof.
   intros.
-  psatzl R.
+  lra.
 Qed.
 
 Goal forall x, -x^2 >= 0 -> x - 1 >= 0 -> False.
@@ -72,5 +78,11 @@ Proof.
 Qed.
 
 Lemma l1 : forall x y z : R, Rabs (x - z) <= Rabs (x - y) + Rabs (y - z).
-intros; split_Rabs; psatzl R.
-Qed.
\ No newline at end of file
+intros; split_Rabs; lra.
+Qed.
+
+(*  Bug 5073 *)
+Lemma opp_eq_0_iff a : -a = 0 <-> a = 0.
+Proof.
+  lra.
+Qed.
diff --git a/test-suite/micromega/square.v b/test-suite/micromega/square.v
index 8767f687..abf8be72 100644
--- a/test-suite/micromega/square.v
+++ b/test-suite/micromega/square.v
@@ -53,8 +53,7 @@ Qed.
 
 Theorem sqrt2_not_rational : ~exists x:Q, x^2==2#1.
 Proof.
- unfold Qeq; intros [x]; simpl (Qden (2#1)); rewrite Z.mul_1_r.
- intros HQeq.
+ unfold Qeq; intros (x,HQeq); simpl (Qden (2#1)) in HQeq; rewrite Z.mul_1_r in HQeq.
  assert (Heq : (Qnum x ^ 2 = 2 * ' Qden x ^ 2%Q)%Z) by
    (rewrite QnumZpower in HQeq ; rewrite QdenZpower in HQeq ; auto).
  assert (Hnx : (Qnum x <> 0)%Z)
diff --git a/test-suite/micromega/zomicron.v b/test-suite/micromega/zomicron.v
index 0ec1dbfb..239bc693 100644
--- a/test-suite/micromega/zomicron.v
+++ b/test-suite/micromega/zomicron.v
@@ -8,9 +8,10 @@ Proof.
   lia.
 Qed.
 
+
 Lemma two_x_y_eq_1 : forall x y, 2 * x + 2 * y = 1 -> False.
 Proof.
-  intros.
+  intros. 
   lia.
 Qed.
 
@@ -20,6 +21,12 @@ Proof.
   lia.
 Qed.
 
+Lemma unused : forall x y, y >= 0 /\ x = 1 -> x = 1.
+Proof.
+  intros x y.
+  lia.
+Qed.
+
 Lemma omega_nightmare : forall x y, 27 <= 11 * x + 13 * y <= 45 ->  -10 <= 7 * x - 9 * y <= 4 -> False.
 Proof.
   intros ; intuition auto.
@@ -33,4 +40,53 @@ Lemma compact_proof : forall z,
 Proof.
  intros.
  lia.
-Qed.
\ No newline at end of file
+Qed.
+
+Lemma dummy_ex : exists (x:Z),  x = x.
+Proof.
+  eexists.
+  lia.
+  Unshelve.
+  exact Z0.
+Qed.
+
+Lemma unused_concl : forall x,
+    False -> x > 0 -> x < 0.
+Proof.
+  intro.
+  lia.
+Qed.
+
+Lemma unused_concl_match : forall (x:Z),
+    False -> match x with
+             | Z0 => True
+             | _ => x = x
+             end.
+Proof.
+  intros.
+  lia.
+Qed.
+
+Lemma fresh : forall (__arith : Prop),
+    __arith -> True.
+Proof.
+  intros.
+  lia.
+Qed.
+
+Class Foo {x : Z} := { T : Type ; dec : T -> Z }.
+Goal forall bound {F : @Foo bound} (x y : T), 0 <= dec x < bound -> 0 <= dec y 
+< bound -> dec x + dec y >= bound -> dec x + dec y < 2 * bound.
+Proof.
+  intros.
+  lia.
+Qed.
+
+(*  Bug 5073 *)
+Lemma opp_eq_0_iff a : -a = 0 <-> a = 0.
+Proof.
+  lia.
+Qed.
+
+
+
diff --git a/test-suite/misc/deps/A/A.v b/test-suite/misc/deps/A/A.v
new file mode 100644
index 00000000..49aaf4a7
--- /dev/null
+++ b/test-suite/misc/deps/A/A.v
@@ -0,0 +1 @@
+Definition b := true.
diff --git a/test-suite/misc/deps/B/A.v b/test-suite/misc/deps/B/A.v
new file mode 100644
index 00000000..c01a30dc
--- /dev/null
+++ b/test-suite/misc/deps/B/A.v
@@ -0,0 +1 @@
+Definition b := false.
diff --git a/test-suite/misc/deps/B/B.v b/test-suite/misc/deps/B/B.v
new file mode 100644
index 00000000..f3cda70a
--- /dev/null
+++ b/test-suite/misc/deps/B/B.v
@@ -0,0 +1,7 @@
+Require A.
+
+Definition c := A.b.
+Lemma foo : c = false.
+Proof.
+reflexivity.
+Qed.
diff --git a/test-suite/misc/deps/checksum.v b/test-suite/misc/deps/checksum.v
new file mode 100644
index 00000000..450045e4
--- /dev/null
+++ b/test-suite/misc/deps/checksum.v
@@ -0,0 +1,2 @@
+Require Import A.
+Fail Require Import B.
diff --git a/test-suite/output-modulo-time/ltacprof.out b/test-suite/output-modulo-time/ltacprof.out
new file mode 100644
index 00000000..cc04c2c9
--- /dev/null
+++ b/test-suite/output-modulo-time/ltacprof.out
@@ -0,0 +1,12 @@
+total time:      1.528s
+
+ tactic                                   local  total   calls       max
+────────────────────────────────────────┴──────┴──────┴───────┴─────────┘
+─sleep' -------------------------------- 100.0% 100.0%       1    1.528s
+─constructor ---------------------------   0.0%   0.0%       1    0.000s
+
+ tactic                                   local  total   calls       max
+────────────────────────────────────────┴──────┴──────┴───────┴─────────┘
+─sleep' -------------------------------- 100.0% 100.0%       1    1.528s
+─constructor ---------------------------   0.0%   0.0%       1    0.000s
+
diff --git a/test-suite/output-modulo-time/ltacprof.v b/test-suite/output-modulo-time/ltacprof.v
new file mode 100644
index 00000000..6611db70
--- /dev/null
+++ b/test-suite/output-modulo-time/ltacprof.v
@@ -0,0 +1,8 @@
+(* -*- coq-prog-args: ("-emacs" "-profile-ltac-cutoff" "0.0") -*- *)
+Ltac sleep' := do 100 (do 100 (do 100 idtac)).
+Ltac sleep := sleep'.
+
+Theorem x : True.
+Proof.
+  idtac. idtac. sleep. constructor.
+Defined.
diff --git a/test-suite/output-modulo-time/ltacprof_cutoff.out b/test-suite/output-modulo-time/ltacprof_cutoff.out
new file mode 100644
index 00000000..0cd5777c
--- /dev/null
+++ b/test-suite/output-modulo-time/ltacprof_cutoff.out
@@ -0,0 +1,31 @@
+total time:      1.584s
+
+ tactic                                   local  total   calls       max 
+────────────────────────────────────────┴──────┴──────┴───────┴─────────┘
+─foo2 ----------------------------------   0.0% 100.0%       1    1.584s
+─sleep --------------------------------- 100.0% 100.0%       3    0.572s
+─foo1 ----------------------------------   0.0%  63.9%       1    1.012s
+
+ tactic                                   local  total   calls       max 
+────────────────────────────────────────┴──────┴──────┴───────┴─────────┘
+─foo2 ----------------------------------   0.0% 100.0%       1    1.584s
+└foo1 ----------------------------------   0.0%  63.9%       1    1.012s
+
+total time:      1.584s
+
+ tactic                                   local  total   calls       max 
+────────────────────────────────────────┴──────┴──────┴───────┴─────────┘
+─sleep --------------------------------- 100.0% 100.0%       3    0.572s
+─foo2 ----------------------------------   0.0% 100.0%       1    1.584s
+─foo1 ----------------------------------   0.0%  63.9%       1    1.012s
+─foo0 ----------------------------------   0.0%  31.3%       1    0.496s
+
+ tactic                                   local  total   calls       max 
+────────────────────────────────────────┴──────┴──────┴───────┴─────────┘
+─foo2 ----------------------------------   0.0% 100.0%       1    1.584s
+ ├─foo1 --------------------------------   0.0%  63.9%       1    1.012s
+ │ ├─sleep -----------------------------  32.6%  32.6%       1    0.516s
+ │ └─foo0 ------------------------------   0.0%  31.3%       1    0.496s
+ │  └sleep -----------------------------  31.3%  31.3%       1    0.496s
+ └─sleep -------------------------------  36.1%  36.1%       1    0.572s
+
diff --git a/test-suite/output-modulo-time/ltacprof_cutoff.v b/test-suite/output-modulo-time/ltacprof_cutoff.v
new file mode 100644
index 00000000..50131470
--- /dev/null
+++ b/test-suite/output-modulo-time/ltacprof_cutoff.v
@@ -0,0 +1,12 @@
+(* -*- coq-prog-args: ("-emacs" "-profile-ltac") -*- *)
+Require Coq.ZArith.BinInt.
+Ltac sleep := do 50 (idtac; let sleep := (eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl) in idtac).
+
+Ltac foo0 := idtac; sleep.
+Ltac foo1 := sleep; foo0.
+Ltac foo2 := sleep; foo1.
+Goal True.
+  foo2.
+  Show Ltac Profile CutOff 47.
+  constructor.
+Qed.
diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out
index 2c7b04c6..a2ee2d4c 100644
--- a/test-suite/output/Arguments.out
+++ b/test-suite/output/Arguments.out
@@ -101,4 +101,4 @@ Error: Unknown interpretation for notation "$".
 w 3 true = tt
      : Prop
 The command has indeed failed with message:
-Error: Extra argument _.
+Error: Extra arguments: _, _.
diff --git a/test-suite/output/Arguments.v b/test-suite/output/Arguments.v
index 05eeaac6..bd924047 100644
--- a/test-suite/output/Arguments.v
+++ b/test-suite/output/Arguments.v
@@ -17,7 +17,7 @@ Definition fcomp A B C f (g : A -> B) (x : A) : C := f (g x).
 Arguments fcomp {_ _ _}%type_scope f g x /.
 About fcomp.
 Definition volatile := fun x : nat => x.
-Arguments volatile /.
+Arguments volatile / _.
 About volatile.
 Set Implicit Arguments.
 Section S1.
diff --git a/test-suite/output/ArgumentsScope.v b/test-suite/output/ArgumentsScope.v
index 1ff53294..3a90cb79 100644
--- a/test-suite/output/ArgumentsScope.v
+++ b/test-suite/output/ArgumentsScope.v
@@ -11,11 +11,11 @@ About b.
 About negb''.
 About negb'.
 About negb.
-Global Arguments Scope negb'' [ _ ].
-Global Arguments Scope negb' [ _ ].
-Global Arguments Scope negb [ _ ].
-Global Arguments Scope a [ _ ].
-Global Arguments Scope b [ _ ].
+Global Arguments negb'' _ : clear scopes.
+Global Arguments negb' _ : clear scopes.
+Global Arguments negb _ : clear scopes.
+Global Arguments a _ : clear scopes.
+Global Arguments b _ : clear scopes.
 About a.
 About b.
 About negb.
diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out
index 1e3cc37d..b084ad49 100644
--- a/test-suite/output/Arguments_renaming.out
+++ b/test-suite/output/Arguments_renaming.out
@@ -1,13 +1,17 @@
 The command has indeed failed with message:
 Error: To rename arguments the "rename" flag must be specified.
 Argument A renamed to B.
-The command has indeed failed with message:
-Error: To rename arguments the "rename" flag must be specified.
-Argument A renamed to T.
+File "stdin", line 2, characters 0-25:
+Warning: This command is just asserting the names of arguments of identity.
+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' [arguments-assert,vernacular]
 @eq_refl
      : forall (B : Type) (y : B), y = y
-@eq_refl nat
-     : forall x : nat, x = x
+eq_refl
+     : ?y = ?y
+where
+?y : [ |- nat] 
 Inductive eq (A : Type) (x : A) : A -> Prop :=  eq_refl : x = x
 
 For eq_refl: Arguments are renamed to B, y
@@ -99,15 +103,15 @@ Expands to: Constant Top.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.
+Error: Argument lists should agree on the names they provide.
 The command has indeed failed with message:
-Error: The following arguments are not declared: x.
+Error: Sequences of implicit arguments must be of different lengths.
 The command has indeed failed with message:
-Error: Arguments names must be distinct.
+Error: Some argument names are duplicated: F
 The command has indeed failed with message:
 Error: Argument z cannot be declared implicit.
 The command has indeed failed with message:
-Error: Extra argument y.
+Error: Extra arguments: y.
 The command has indeed failed with message:
 Error: To rename arguments the "rename" flag must be specified.
 Argument A renamed to R.
diff --git a/test-suite/output/Arguments_renaming.v b/test-suite/output/Arguments_renaming.v
index e68fbd69..0cb33134 100644
--- a/test-suite/output/Arguments_renaming.v
+++ b/test-suite/output/Arguments_renaming.v
@@ -1,6 +1,6 @@
 Fail Arguments eq_refl {B y}, [B] y.
-Fail Arguments identity T _ _.
-Arguments eq_refl A x.
+Arguments identity A _ _.
+Arguments eq_refl A x : assert.
 Arguments eq_refl {B y}, [B] y : rename.
 
 Check @eq_refl.
@@ -46,9 +46,9 @@ About myplus.
 Check @myplus.
 
 Fail Arguments eq_refl {F g}, [H] k.
-Fail Arguments eq_refl {F}, [F].
-Fail Arguments eq_refl {F F}, [F] F.
-Fail Arguments eq {F} x [z].
+Fail Arguments eq_refl {F}, [F] : rename.
+Fail Arguments eq_refl {F F}, [F] F : rename.
+Fail Arguments eq {F} x [z] : rename.
 Fail Arguments eq {F} x z y.
 Fail Arguments eq {R} s t.
 
diff --git a/test-suite/output/Binder.out b/test-suite/output/Binder.out
new file mode 100644
index 00000000..34558e9a
--- /dev/null
+++ b/test-suite/output/Binder.out
@@ -0,0 +1,8 @@
+foo = fun '(x, y) => x + y
+     : nat * nat -> nat
+forall '(a, b), a /\ b
+     : Prop
+foo = λ '(x, y), x + y
+     : nat * nat → nat
+∀ '(a, b), a ∧ b
+     : Prop
diff --git a/test-suite/output/Binder.v b/test-suite/output/Binder.v
new file mode 100644
index 00000000..9aced9f6
--- /dev/null
+++ b/test-suite/output/Binder.v
@@ -0,0 +1,7 @@
+Definition foo '(x,y) := x + y.
+Print foo.
+Check forall '(a,b), a /\ b.
+
+Require Import Utf8.
+Print foo.
+Check forall '(a,b), a /\ b.
diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out
index 09f032d4..8ce6f979 100644
--- a/test-suite/output/Cases.out
+++ b/test-suite/output/Cases.out
@@ -6,6 +6,8 @@ fix F (t : t) : P t :=
   end
      : forall P : t -> Type,
        (let x := t in forall x0 : x, P x0 -> P (k x0)) -> forall t : t, P t
+
+Argument scopes are [function_scope function_scope _]
      = fun d : TT => match d with
                      | @CTT _ _ b => b
                      end
@@ -24,7 +26,7 @@ match Nat.eq_dec x y with
 end
      : forall (x y : nat) (P : nat -> Type), P x -> P y -> P y
 
-Argument scopes are [nat_scope nat_scope _ _ _]
+Argument scopes are [nat_scope nat_scope function_scope _ _]
 foo = 
 fix foo (A : Type) (l : list A) {struct l} : option A :=
   match l with
@@ -48,9 +50,25 @@ f =
 fun H : B =>
 match H with
 | AC x =>
-    (let b0 := b in
-     if b0 as b return (P b -> True)
+    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
+The command has indeed failed with message:
+Non exhaustive pattern-matching: no clause found for pattern 
+gadtTy _ _
+The command has indeed failed with message:
+In environment
+texpDenote : forall t : type, texp t -> typeDenote t
+t : type
+e : texp t
+t1 : type
+t2 : type
+t0 : type
+b : tbinop t1 t2 t0
+e1 : texp t1
+e2 : texp t2
+The term "0" has type "nat" while it is expected to have type
+ "typeDenote t0".
diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v
index 4116a5eb..40748964 100644
--- a/test-suite/output/Cases.v
+++ b/test-suite/output/Cases.v
@@ -66,14 +66,43 @@ 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.
+Axiom b : bool.
+Axiom P : bool -> Prop.
 Inductive B : Prop := AC : P b -> B.
 Definition f : B -> True.
 
 Proof.
-intros [].
-destruct b as [|] ; intros _ ; exact Logic.I.
+intros [x].
+destruct b as [|] ; exact Logic.I.
 Defined.
 
 Print f.
+
+(* Was enhancement request #5142 (error message reported on the most
+   general return clause heuristic) *)
+
+Inductive gadt : Type -> Type :=
+| gadtNat : nat -> gadt nat
+| gadtTy : forall T, T -> gadt T.
+
+Fail Definition gadt_id T (x: gadt T) : gadt T :=
+  match x with
+  | gadtNat n => gadtNat n
+  end.
+
+(* A variant of #5142 (see Satrajit Roy's example on coq-club (Oct 17, 2016)) *)
+
+Inductive type:Set:=Nat.
+Inductive tbinop:type->type->type->Set:= TPlus : tbinop Nat Nat Nat.
+Inductive texp:type->Set:=
+ |TNConst:nat->texp Nat
+ |TBinop:forall t1 t2 t, tbinop t1 t2 t->texp t1->texp t2->texp t.
+Definition typeDenote(t:type):Set:= match t with Nat => nat end.
+
+(* We expect a failure on TBinop *)
+Fail Fixpoint texpDenote t (e:texp t):typeDenote t:=
+  match e with
+  | TNConst n => n
+  | TBinop t1 t2 _ b e1 e2 => O
+  end.
+
diff --git a/test-suite/output/Errors.out b/test-suite/output/Errors.out
index 6354ad46..06a6b2d1 100644
--- a/test-suite/output/Errors.out
+++ b/test-suite/output/Errors.out
@@ -5,3 +5,6 @@ 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.
 Unable to unify "nat" with "True".
+The command has indeed failed with message:
+Ltac call to "instantiate ( (ident) := (lglob) )" failed.
+Error: Instance is not well-typed in the environment of ?x.
diff --git a/test-suite/output/Errors.v b/test-suite/output/Errors.v
index 352c8738..424d2480 100644
--- a/test-suite/output/Errors.v
+++ b/test-suite/output/Errors.v
@@ -16,3 +16,12 @@ Goal True.
 Fail simpl; apply 0.
 Fail simpl; f 0.
 Abort.
+
+(* Test instantiate error messages *)
+
+Goal forall T1 (P1 : T1 -> Type), sigT P1 -> sigT P1.
+intros T1 P1 H1.
+eexists ?[x].
+destruct H1 as [x1 H1].
+Fail instantiate (x:=projT1 x1).
+Abort.
diff --git a/test-suite/output/Existentials.out b/test-suite/output/Existentials.out
index 52e1e0ed..9680d2bb 100644
--- a/test-suite/output/Existentials.out
+++ b/test-suite/output/Existentials.out
@@ -1,5 +1,4 @@
-Existential 1 =
-?Goal1 : [p : nat  q := S p : nat  n : nat  m : nat |- ?y = m] 
+Existential 1 = ?Goal : [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 = ?Goal0 : [q : nat  n : nat  m : nat |- n = ?y] 
diff --git a/test-suite/output/InitSyntax.out b/test-suite/output/InitSyntax.out
index bbfd3405..c17c63e7 100644
--- a/test-suite/output/InitSyntax.out
+++ b/test-suite/output/InitSyntax.out
@@ -4,7 +4,8 @@ Inductive sig2 (A : Type) (P Q : A -> Prop) : Type :=
 For sig2: Argument A is implicit
 For exist2: Argument A is implicit
 For sig2: Argument scopes are [type_scope type_scope type_scope]
-For exist2: Argument scopes are [type_scope _ _ _ _ _]
+For exist2: Argument scopes are [type_scope function_scope function_scope _ _
+              _]
 exists x : nat, x = x
      : Prop
 fun b : bool => if b then b else b
diff --git a/test-suite/output/Intuition.out b/test-suite/output/Intuition.out
index e99d9fde..f2bf25ca 100644
--- a/test-suite/output/Intuition.out
+++ b/test-suite/output/Intuition.out
@@ -3,4 +3,4 @@
   m, n : Z
   H : (m >= n)%Z
   ============================
-   (m >= m)%Z
+  (m >= m)%Z
diff --git a/test-suite/output/Naming.out b/test-suite/output/Naming.out
index f0d2562e..c142d28e 100644
--- a/test-suite/output/Naming.out
+++ b/test-suite/output/Naming.out
@@ -2,40 +2,40 @@
   
   x3 : nat
   ============================
-   forall x x1 x4 x0 : nat,
-   (forall x2 x5 : nat, x2 + x1 = x4 + x5) -> x + x1 = x4 + x0
+  forall x x1 x4 x0 : nat,
+  (forall x2 x5 : nat, x2 + x1 = x4 + x5) -> x + x1 = x4 + x0
 1 subgoal
   
   x3, x, x1, x4, x0 : nat
   H : forall x x3 : nat, x + x1 = x4 + x3
   ============================
-   x + x1 = x4 + x0
+  x + x1 = x4 + x0
 1 subgoal
   
   x3 : nat
   ============================
-   forall x x1 x4 x0 : nat,
-   (forall x2 x5 : nat, x2 + x1 = x4 + x5 -> foo (S x2 + x1)) ->
-   x + x1 = x4 + x0 -> foo (S x)
+  forall x x1 x4 x0 : nat,
+  (forall x2 x5 : nat, x2 + x1 = x4 + x5 -> foo (S x2 + x1)) ->
+  x + x1 = x4 + x0 -> foo (S x)
 1 subgoal
   
   x3 : nat
   ============================
-   forall x x1 x4 x0 : nat,
-   (forall x2 x5 : nat,
-    x2 + x1 = x4 + x5 ->
-    forall x6 x7 x8 S0 : nat, x6 + S0 = x7 + x8 + (S x2 + x1)) ->
-   x + x1 = x4 + x0 ->
-   forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x
+  forall x x1 x4 x0 : nat,
+  (forall x2 x5 : nat,
+   x2 + x1 = x4 + x5 ->
+   forall x6 x7 x8 S0 : nat, x6 + S0 = x7 + x8 + (S x2 + x1)) ->
+  x + x1 = x4 + x0 ->
+  forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x
 1 subgoal
   
   x3, x, x1, x4, x0 : nat
   ============================
-   (forall x2 x5 : nat,
-    x2 + x1 = x4 + x5 ->
-    forall x6 x7 x8 S0 : nat, x6 + S0 = x7 + x8 + (S x2 + x1)) ->
-   x + x1 = x4 + x0 ->
-   forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x
+  (forall x2 x5 : nat,
+   x2 + x1 = x4 + x5 ->
+   forall x6 x7 x8 S0 : nat, x6 + S0 = x7 + x8 + (S x2 + x1)) ->
+  x + x1 = x4 + x0 ->
+  forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x
 1 subgoal
   
   x3, x, x1, x4, x0 : nat
@@ -44,7 +44,7 @@
       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
+  forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x
 1 subgoal
   
   x3, x, x1, x4, x0 : nat
@@ -54,10 +54,10 @@
   H0 : x + x1 = x4 + x0
   x5, x6, x7, S : nat
   ============================
-   x5 + S = x6 + x7 + Datatypes.S x
+  x5 + S = x6 + x7 + Datatypes.S x
 1 subgoal
   
   x3, a : nat
   H : a = 0 -> forall a : nat, a = 0
   ============================
-   a = 0
+  a = 0
diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out
index b1558dab..26eaca82 100644
--- a/test-suite/output/Notations.out
+++ b/test-suite/output/Notations.out
@@ -111,14 +111,14 @@ fun x : option Z => match x with
                     | NONE2 => 0
                     end
      : option Z -> Z
-fun x : list ?T1 => match x with
-                    | NIL => NONE2
-                    | (_ :') t => SOME2 t
-                    end
-     : list ?T1 -> option (list ?T1)
+fun x : list ?T => match x with
+                   | NIL => NONE2
+                   | (_ :') t => SOME2 t
+                   end
+     : list ?T -> option (list ?T)
 where
-?T1 : [x : list ?T1  x1 : list ?T1  x0 := x1 : list ?T1 |- Type] (x, x1,
-      x0 cannot be used)
+?T : [x : list ?T  x1 : list ?T  x0 := x1 : list ?T |- Type] (x, x1,
+     x0 cannot be used)
 s
      : s
 10
diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v
index adba688e..2ccca829 100644
--- a/test-suite/output/Notations.v
+++ b/test-suite/output/Notations.v
@@ -133,8 +133,7 @@ Fail Notation "( x , y , .. , z )" := (pair x (pair y z)).
 Fail Notation "( x , y , .. , z )" := (pair x .. (pair y w) ..).
 
 (* Right-unbound variable *)
-(* Now allowed with an only parsing restriction *)
-Notation "( x , y , .. , z )" := (pair y .. (pair z 0) ..).
+Notation "( x , y , .. , z )" := (pair y .. (pair z 0) ..) (only parsing).
 
 (* Not the right kind of recursive pattern *)
 Fail Notation "( x , y , .. , z )" := (ex (fun z => .. (ex (fun y => x)) ..)).
diff --git a/test-suite/output/Notations2.out b/test-suite/output/Notations2.out
index 58ec1de5..ad60aecc 100644
--- a/test-suite/output/Notations2.out
+++ b/test-suite/output/Notations2.out
@@ -12,7 +12,7 @@ let '(a, _, _) := (2, 3, 4) in a
      : nat
 exists myx y : bool, myx = y
      : Prop
-fun (P : nat -> nat -> Prop) (x : nat) => exists x0, P x x0
+fun (P : nat -> nat -> Prop) (x : nat) => exists y, P x y
      : (nat -> nat -> Prop) -> nat -> Prop
 ∃ n p : nat, n + p = 0
      : Prop
@@ -50,3 +50,37 @@ end
      : nat -> nat
 # _ : nat => 2
      : nat -> nat
+# x : nat => # H : x <= 0 => exist (le x) 0 H
+     : ∀ x : nat, x <= 0 -> {x0 : nat | x <= x0}
+exist (Q x) y conj
+     : {x0 : A | Q x x0}
+% i
+     : nat -> nat
+% j
+     : nat -> nat
+{1, 2}
+     : nat -> Prop
+a#
+     : Set
+a#
+     : Set
+a≡
+     : Set
+a≡
+     : Set
+.≡
+     : Set
+.≡
+     : Set
+.a#
+     : Set
+.a#
+     : Set
+.a≡
+     : Set
+.a≡
+     : Set
+.α
+     : Set
+.α
+     : Set
diff --git a/test-suite/output/Notations2.v b/test-suite/output/Notations2.v
index e53c94ef..ceb29d1b 100644
--- a/test-suite/output/Notations2.v
+++ b/test-suite/output/Notations2.v
@@ -68,6 +68,7 @@ Check let' f x y (a:=0) z (b:bool) := x+y+z+1 in f 0 1 2.
 
 (* In practice, only the printing rule is used here *)
 (* Note: does not work for pattern *)
+Module A.
 Notation "f ( x )" := (f x) (at level 10, format "f ( x )").
 Check fun f x => f x + S x.
 
@@ -77,6 +78,7 @@ Notation plus2 n := (S (S n)).
 (* plus2 was not correctly printed in the two following tests in 8.3pl1 *)
 Print plus2.
 Check fun n => match n with list1 => 0 | _ => 2 end.
+End A.
 
 (* This one is not fully satisfactory because binders in the same type
    are re-factorized and parentheses are needed even for atomic binder
@@ -98,3 +100,48 @@ Notation "#  x : T => t" := (fun x : T => t)
 
 Check # x : nat => x.
 Check # _ : nat => 2.
+
+(* Check bug 4677 *)
+Check fun x (H:le x 0) => exist (le x) 0 H.
+
+Parameters (A : Set) (x y : A) (Q : A -> A -> Prop) (conj : Q x y).
+Check (exist (Q x) y conj).
+
+(* Check bug #4854 *)
+Notation "% i" := (fun i : nat => i) (at level 0, i ident).
+Check %i.
+Check %j.
+
+(* Check bug raised on coq-club on Sep 12, 2016 *)
+
+Notation "{ x , y , .. , v }" := (fun a => (or .. (or (a = x) (a = y)) .. (a = v))).
+Check ({1, 2}).
+
+(**********************************************************************)
+(* Check notations of the form ".a", ".a≡", "a≡"                      *)
+(* Only "a#", "a≡" and ".≡" were working properly for parsing. The    *)
+(* other ones were working only for printing.                         *)
+
+Notation "a#" := nat.
+Check nat.
+Check a#.
+
+Notation "a≡" := nat.
+Check nat.
+Check a≡.
+
+Notation ".≡" := nat.
+Check nat.
+Check .≡.
+
+Notation ".a#" := nat.
+Check nat.
+Check .a#.
+
+Notation ".a≡" := nat.
+Check nat.
+Check .a≡.
+
+Notation ".α" := nat.
+Check nat.
+Check .α.
diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out
new file mode 100644
index 00000000..360f3796
--- /dev/null
+++ b/test-suite/output/Notations3.out
@@ -0,0 +1,100 @@
+[<0, 2 >]
+     : nat * nat * (nat * nat)
+[<0, 2 >]
+     : nat * nat * (nat * nat)
+(0, 2, (2, 2))
+     : nat * nat * (nat * nat)
+pair (pair O (S (S O))) (pair (S (S O)) O)
+     : prod (prod nat nat) (prod nat nat)
+<< 0, 2, 4 >>
+     : nat * nat * nat * (nat * (nat * nat))
+<< 0, 2, 4 >>
+     : nat * nat * nat * (nat * (nat * nat))
+(0, 2, 4, (2, (2, 0)))
+     : nat * nat * nat * (nat * (nat * nat))
+(0, 2, 4, (0, (2, 4)))
+     : nat * nat * nat * (nat * (nat * nat))
+pair (pair (pair O (S (S O))) (S (S (S (S O)))))
+  (pair (S (S (S (S O)))) (pair (S (S O)) O))
+     : prod (prod (prod nat nat) nat) (prod nat (prod nat nat))
+ETA x y : nat, Nat.add
+     : nat -> nat -> nat
+ETA x y : nat, Nat.add
+     : nat -> nat -> nat
+ETA x y : nat, Nat.add
+     : nat -> nat -> nat
+fun x y : nat => Nat.add x y
+     : forall (_ : nat) (_ : nat), nat
+ETA x y : nat, le_S
+     : forall x y : nat, x <= y -> x <= S y
+fun f : forall x : nat * (bool * unit), ?T => CURRY (x : nat) (y : bool), f
+     : (forall x : nat * (bool * unit), ?T) ->
+       forall (x : nat) (y : bool), ?T@{x:=(x, (y, tt))}
+where
+?T : [x : nat * (bool * unit) |- Type] 
+fun f : forall x : bool * (nat * unit), ?T =>
+CURRYINV (x : nat) (y : bool), f
+     : (forall x : bool * (nat * unit), ?T) ->
+       forall (x : nat) (y : bool), ?T@{x:=(y, (x, tt))}
+where
+?T : [x : bool * (nat * unit) |- Type] 
+fun f : forall x : unit * nat * bool, ?T => CURRYLEFT (x : nat) (y : bool), f
+     : (forall x : unit * nat * bool, ?T) ->
+       forall (x : nat) (y : bool), ?T@{x:=(tt, x, y)}
+where
+?T : [x : unit * nat * bool |- Type] 
+fun f : forall x : unit * bool * nat, ?T =>
+CURRYINVLEFT (x : nat) (y : bool), f
+     : (forall x : unit * bool * nat, ?T) ->
+       forall (x : nat) (y : bool), ?T@{x:=(tt, y, x)}
+where
+?T : [x : unit * bool * nat |- Type] 
+forall n : nat, {#n | 1 > n}
+     : Prop
+forall x : nat, {|x | x > 0|}
+     : Prop
+exists2 x : nat, x = 1 & x = 2
+     : Prop
+fun n : nat =>
+foo2 n (fun x y z : nat => (fun _ _ _ : nat => x + y + z = 0) z y x)
+     : nat -> Prop
+fun n : nat =>
+foo2 n (fun a b c : nat => (fun _ _ _ : nat => a + b + c = 0) c b a)
+     : nat -> Prop
+fun n : nat =>
+foo2 n (fun n0 y z : nat => (fun _ _ _ : nat => n0 + y + z = 0) z y n0)
+     : nat -> Prop
+fun n : nat =>
+foo2 n (fun x n0 z : nat => (fun _ _ _ : nat => x + n0 + z = 0) z n0 x)
+     : nat -> Prop
+fun n : nat =>
+foo2 n (fun x y n0 : nat => (fun _ _ _ : nat => x + y + n0 = 0) n0 y x)
+     : nat -> Prop
+fun n : nat => {|n, y | fun _ _ _ : nat => n + y = 0 |}_2
+     : nat -> Prop
+fun n : nat => {|n, y | fun _ _ _ : nat => n + y = 0 |}_2
+     : nat -> Prop
+fun n : nat => {|n, n0 | fun _ _ _ : nat => n + n0 = 0 |}_2
+     : nat -> Prop
+fun n : nat =>
+foo2 n (fun x y z : nat => (fun _ _ _ : nat => x + y + n = 0) z y x)
+     : nat -> Prop
+fun n : nat =>
+foo2 n (fun x y z : nat => (fun _ _ _ : nat => x + y + n = 0) z y x)
+     : nat -> Prop
+fun n : nat => {|n, fun _ : nat => 0 = 0 |}_3
+     : nat -> Prop
+fun n : nat => {|n, fun _ : nat => n = 0 |}_3
+     : nat -> Prop
+fun n : nat => foo3 n (fun x _ : nat => ETA z : nat, (fun _ : nat => x = 0))
+     : nat -> Prop
+fun n : nat => {|n, fun _ : nat => 0 = 0 |}_4
+     : nat -> Prop
+fun n : nat => {|n, fun _ : nat => n = 0 |}_4
+     : nat -> Prop
+fun n : nat => foo4 n (fun _ _ : nat => ETA z : nat, (fun _ : nat => z = 0))
+     : nat -> Prop
+fun n : nat => foo4 n (fun _ y : nat => ETA z : nat, (fun _ : nat => y = 0))
+     : nat -> Prop
+tele (t : Type) '(y, z) (x : t0) := tt
+     : forall t : Type, nat * nat -> t -> fpack
diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v
new file mode 100644
index 00000000..4b8bfe31
--- /dev/null
+++ b/test-suite/output/Notations3.v
@@ -0,0 +1,141 @@
+(**********************************************************************)
+(* Check printing of notations with several instances of a recursive pattern *)
+(* Was wrong but I could not trigger a problem due to the collision between *)
+(* different instances of ".." *)
+
+Notation "[< x , y , .. , z >]" := (pair (.. (pair x y) ..) z,pair y ( .. (pair z x) ..)).
+Check [<0,2>].
+Check ((0,2),(2,0)).
+Check ((0,2),(2,2)).
+Unset Printing Notations.
+Check [<0,2>].
+Set Printing Notations.
+
+Notation "<< x , y , .. , z >>" := ((.. (x,y) .., z),(z, .. (y,x) ..)).
+Check <<0,2,4>>.
+Check (((0,2),4),(4,(2,0))).
+Check (((0,2),4),(2,(2,0))).
+Check (((0,2),4),(0,(2,4))).
+Unset Printing Notations.
+Check <<0,2,4>>.
+Set Printing Notations.
+
+(**********************************************************************)
+(* Check notations with recursive notations both in binders and terms *)
+
+Notation "'ETA' x .. y , f" :=
+  (fun x => .. (fun y => (.. (f x) ..) y ) ..)
+  (at level 200, x binder, y binder).
+Check ETA (x:nat) (y:nat), Nat.add.
+Check ETA (x y:nat), Nat.add.
+Check ETA x y, Nat.add.
+Unset Printing Notations.
+Check ETA (x:nat) (y:nat), Nat.add.
+Set Printing Notations.
+Check ETA x y, le_S.
+
+Notation "'CURRY' x .. y , f" := (fun x => .. (fun y => f (x, .. (y,tt) ..)) ..)
+  (at level 200, x binder, y binder).
+Check fun f => CURRY (x:nat) (y:bool), f.
+
+Notation "'CURRYINV' x .. y , f" := (fun x => .. (fun y => f (y, .. (x,tt) ..)) ..)
+  (at level 200, x binder, y binder).
+Check fun f => CURRYINV (x:nat) (y:bool), f.
+
+Notation "'CURRYLEFT' x .. y , f" := (fun x => .. (fun y => f (.. (tt,x) .., y)) ..)
+  (at level 200, x binder, y binder).
+Check fun f => CURRYLEFT (x:nat) (y:bool), f.
+
+Notation "'CURRYINVLEFT' x .. y , f" := (fun x => .. (fun y => f (.. (tt,y) .., x)) ..)
+  (at level 200, x binder, y binder).
+Check fun f => CURRYINVLEFT (x:nat) (y:bool), f.
+
+(**********************************************************************)
+(* Notations with variables bound both as a term and as a binder      *)
+(* This is #4592 *)
+
+Notation "{# x | P }" := (ex2 (fun y => x = y) (fun x => P)).
+Check forall n:nat, {# n | 1 > n}.
+
+Parameter foo : forall {T}(x : T)(P : T -> Prop), Prop.
+Notation "{| x | P |}" := (foo x (fun x => P)).
+Check forall x:nat, {| x | x > 0 |}.
+
+Check ex2 (fun x => x=1) (fun x0 => x0=2).
+
+(* Other tests about alpha-conversions: the following notation
+   contains all three kinds of bindings:
+
+   - x is bound in the lhs as a term and a binder: its name is forced
+     by its position as a term; it can bind variables in P
+   - y is bound in the lhs as a binder only: its name is given by its
+     name as a binder in the term to display; it can bind variables in P
+   - z is a binder local to the rhs; it cannot bind a variable in P
+*)
+
+Parameter foo2 : forall {T}(x : T)(P : T -> T -> T -> Prop), Prop.
+Notation "{| x , y | P |}_2" := (foo2 x (fun x y z => P z y x)).
+
+(* Not printable: z (resp c, n) occurs in P *)
+Check fun n => foo2 n (fun x y z => (fun _ _ _ => x+y+z=0) z y x).
+Check fun n => foo2 n (fun a b c => (fun _ _ _ => a+b+c=0) c b a).
+Check fun n => foo2 n (fun n y z => (fun _ _ _ => n+y+z=0) z y n).
+Check fun n => foo2 n (fun x n z => (fun _ _ _ => x+n+z=0) z n x).
+Check fun n => foo2 n (fun x y n => (fun _ _ _ => x+y+n=0) n y x).
+
+(* Printable *)
+Check fun n => foo2 n (fun x y z => (fun _ _ _ => x+y=0) z y x).
+Check fun n => foo2 n (fun n y z => (fun _ _ _ => n+y=0) z y n).
+Check fun n => foo2 n (fun x n z => (fun _ _ _ => x+n=0) z n x).
+
+(* Not printable: renaming x into n would bind the 2nd occurrence of n *)
+Check fun n => foo2 n (fun x y z => (fun _ _ _ => x+y+n=0) z y x).
+Check fun n => foo2 n (fun x y z => (fun _ _ _ => x+y+n=0) z y x).
+
+(* Other tests *)
+Parameter foo3 : forall {T}(x : T)(P : T -> T -> T -> Prop), Prop.
+Notation "{| x , P |}_3" := (foo3 x (fun x x x => P x)).
+
+(* Printable *)
+Check fun n : nat => foo3 n (fun x y z => (fun _ => 0=0) z).
+Check fun n => foo3 n (fun x y z => (fun _ => z=0) z).
+
+(* Not printable: renaming z in n would hide the renaming of x into n *)
+Check fun n => foo3 n (fun x y z => (fun _ => x=0) z).
+
+(* Other tests *)
+Parameter foo4 : forall {T}(x : T)(P : T -> T -> T -> Prop), Prop.
+Notation "{| x , P |}_4" := (foo4 x (fun x _ z => P z)).
+
+(* Printable *)
+Check fun n : nat => foo4 n (fun x y z => (fun _ => 0=0) z).
+Check fun n => foo4 n (fun x y z => (fun _ => x=0) z).
+
+(* Not printable: y, z not allowed to occur in P *)
+Check fun n => foo4 n (fun x y z => (fun _ => z=0) z).
+Check fun n => foo4 n (fun x y z => (fun _ => y=0) z).
+
+(**********************************************************************)
+(* Test printing of #4932                                             *)
+
+Inductive ftele : Type :=
+| fb {T:Type} : T -> ftele
+| fr {T} : (T -> ftele) -> ftele.
+
+Fixpoint args ftele : Type :=
+  match ftele with
+    | fb _ => unit
+    | fr f => sigT (fun t => args (f t))
+  end.
+
+Definition fpack := sigT args.
+Definition pack fp fa : fpack := existT _ fp fa.
+
+Notation "'tele' x .. z := b" :=
+  (fun x => .. (fun z =>
+     pack (fr (fun x => .. ( fr (fun z => fb b) ) .. ) )
+          (existT _ x .. (existT _ z tt) .. )
+                ) ..)
+  (at level 85, x binder, z binder).
+
+Check tele (t:Type) '((y,z):nat*nat) (x:t) := tt.
diff --git a/test-suite/output/PatternsInBinders.out b/test-suite/output/PatternsInBinders.out
new file mode 100644
index 00000000..c012a86b
--- /dev/null
+++ b/test-suite/output/PatternsInBinders.out
@@ -0,0 +1,39 @@
+swap = fun '(x, y) => (y, x)
+     : A * B -> B * A
+fun '(x, y) => (y, x)
+     : A * B -> B * A
+forall '(x, y), swap (x, y) = (y, x)
+     : Prop
+proj_informative = fun '(exist _ x _) => x : A
+     : {x : A | P x} -> A
+foo = fun '(Bar n b tt p) => if b then n + p else n - p
+     : Foo -> nat
+baz = 
+fun '(Bar n1 _ tt p1) '(Bar _ _ tt _) => n1 + p1
+     : Foo -> Foo -> nat
+swap = 
+fun (A B : Type) '(x, y) => (y, x)
+     : forall A B : Type, A * B -> B * A
+
+Arguments A, B are implicit and maximally inserted
+Argument scopes are [type_scope type_scope _]
+fun (A B : Type) '(x, y) => swap (x, y) = (y, x)
+     : forall A B : Type, A * B -> Prop
+forall (A B : Type) '(x, y), swap (x, y) = (y, x)
+     : Prop
+exists '(x, y), swap (x, y) = (y, x)
+     : Prop
+exists '(x, y) '(z, w), swap (x, y) = (z, w)
+     : Prop
+λ '(x, y), (y, x)
+     : A * B → B * A
+∀ '(x, y), swap (x, y) = (y, x)
+     : Prop
+both_z = 
+fun pat : nat * nat =>
+let '(n, p) as pat0 := pat return (F pat0) in (Z n, Z p) : F (n, p)
+     : forall pat : nat * nat, F pat
+fun '(x, y) '(z, t) => swap (x, y) = (z, t)
+     : A * B -> B * A -> Prop
+forall '(x, y) '(z, t), swap (x, y) = (z, t)
+     : Prop
diff --git a/test-suite/output/PatternsInBinders.v b/test-suite/output/PatternsInBinders.v
new file mode 100644
index 00000000..6fa357a9
--- /dev/null
+++ b/test-suite/output/PatternsInBinders.v
@@ -0,0 +1,66 @@
+Require Coq.Unicode.Utf8.
+
+(** The purpose of this file is to test printing of the destructive
+    patterns used in binders ([fun] and [forall]). *)
+
+Parameters (A B : Type) (P:A->Prop).
+
+Definition swap '((x,y) : A*B) := (y,x).
+Print swap.
+
+Check fun '((x,y) : A*B) => (y,x).
+
+Check forall '(x,y), swap (x,y) = (y,x).
+
+Definition proj_informative '(exist _ x _ : { x:A | P x }) : A := x.
+Print proj_informative.
+
+Inductive Foo := Bar : nat -> bool -> unit -> nat -> Foo.
+Definition foo '(Bar n b tt p) :=
+  if b then n+p else n-p.
+Print foo.
+
+Definition baz '(Bar n1 b1 tt p1) '(Bar n2 b2 tt p2) := n1+p1.
+Print baz.
+
+Module WithParameters.
+
+Definition swap {A B} '((x,y) : A*B) := (y,x).
+Print swap.
+
+Check fun (A B:Type) '((x,y) : A*B) => swap (x,y) = (y,x).
+Check forall (A B:Type) '((x,y) : A*B), swap (x,y) = (y,x).
+
+Check exists '((x,y):A*A), swap (x,y) = (y,x).
+Check exists '((x,y):A*A) '(z,w), swap (x,y) = (z,w).
+
+End WithParameters.
+
+(** Some test involving unicode notations. *)
+Module WithUnicode.
+
+  Import Coq.Unicode.Utf8.
+
+  Check λ '((x,y) : A*B),  (y,x).
+  Check ∀ '(x,y), swap (x,y) = (y,x).
+
+End WithUnicode.
+
+(** * Suboptimal printing *)
+
+Module Suboptimal.
+
+(** This test shows an example which exposes the [let] introduced by
+    the pattern notation in binders. *)
+
+Inductive Fin (n:nat) := Z : Fin n.
+Definition F '(n,p) : Type := (Fin n * Fin p)%type.
+Definition both_z '(n,p) : F (n,p) := (Z _,Z _).
+Print both_z.
+
+(** Test factorization of binders *)
+
+Check fun '((x,y) : A*B) '(z,t) => swap (x,y) = (z,t).
+Check forall '(x,y) '((z,t) : B*A), swap (x,y) = (z,t).
+
+End Suboptimal.
diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out
index ba076f05..1307a8f2 100644
--- a/test-suite/output/PrintInfos.out
+++ b/test-suite/output/PrintInfos.out
@@ -2,7 +2,7 @@ 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 _ _ _]
+Argument scopes are [type_scope function_scope _ _]
 Expands to: Constructor Coq.Init.Specif.existT
 Inductive sigT (A : Type) (P : A -> Type) : Type :=
     existT : forall x : A, P x -> {x : A & P x}
@@ -10,7 +10,7 @@ Inductive sigT (A : Type) (P : A -> Type) : Type :=
 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 _ _ _]
+For existT: Argument scopes are [type_scope function_scope _ _]
 existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x}
 
 Argument A is implicit
@@ -66,14 +66,6 @@ For le_S: Argument n is implicit and maximally inserted
 For le: Argument scopes are [nat_scope nat_scope]
 For le_n: Argument scope is [nat_scope]
 For le_S: Argument scopes are [nat_scope nat_scope _]
-Inductive le (n : nat) : nat -> Prop :=
-    le_n : n <= n | le_S : forall m : nat, n <= m -> n <= S m
-
-For le_S: Argument m is implicit
-For le_S: Argument n is implicit and maximally inserted
-For le: Argument scopes are [nat_scope nat_scope]
-For le_n: Argument scope is [nat_scope]
-For le_S: Argument scopes are [nat_scope nat_scope _]
 comparison : Set
 
 Expands to: Inductive Coq.Init.Datatypes.comparison
@@ -92,19 +84,6 @@ Expanded type for implicit arguments
 bar : forall x : nat, x = 0
 
 Argument x is implicit and maximally inserted
-bar : foo
-
-Expanded type for implicit arguments
-bar : forall x : nat, x = 0
-
-Argument x is implicit and maximally inserted
-Expands to: Constant Top.bar
-*** [ bar : foo ]
-
-Expanded type for implicit arguments
-bar : forall x : nat, x = 0
-
-Argument x is implicit and maximally inserted
 Module Coq.Init.Peano
 Notation existS2 := existT2
 Expands to: Notation Coq.Init.Specif.existS2
@@ -117,15 +96,6 @@ 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 _]
-Inductive eq (A : Type) (x : A) : A -> Prop :=  eq_refl : x = x
-
-For eq: Argument A is implicit and maximally inserted
-For eq_refl, when applied to no arguments:
-  Arguments A, x are implicit and maximally inserted
-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.
diff --git a/test-suite/output/PrintInfos.v b/test-suite/output/PrintInfos.v
index 3c623346..08918981 100644
--- a/test-suite/output/PrintInfos.v
+++ b/test-suite/output/PrintInfos.v
@@ -12,10 +12,7 @@ Print Implicit Nat.add.
 
 About plus_n_O.
 
-Implicit Arguments le_S [[n] m].
-Print le_S.
-
-Arguments le_S {n} [m] _. (* Test new syntax *)
+Arguments le_S {n} [m] _.
 Print le_S.
 
 About comparison.
@@ -23,21 +20,15 @@ Print comparison.
 
 Definition foo := forall x, x = 0.
 Parameter bar : foo.
-Implicit Arguments bar [x].
-About bar.
-Print bar.
 
-Arguments bar [x]. (* Test new syntax *)
+Arguments bar [x].
 About bar.
 Print bar.
 
 About Peano. (* Module *)
 About existS2. (* Notation *)
 
-Implicit Arguments eq_refl [[A] [x]] [[A]].
-Print eq_refl.
-
-Arguments eq_refl {A} {x}, {A} x. (* Test new syntax *)
+Arguments eq_refl {A} {x}, {A} x.
 Print eq_refl.
 
 
diff --git a/test-suite/output/PrintModule.out b/test-suite/output/PrintModule.out
index db464fd0..751d5fcc 100644
--- a/test-suite/output/PrintModule.out
+++ b/test-suite/output/PrintModule.out
@@ -2,3 +2,4 @@ Module N : S with Definition T := nat := M
 
 Module N : S with Module T := K := M
 
+Module Type Func = Funsig (T0:Test) Sig Parameter x : T0.t. End
diff --git a/test-suite/output/PrintModule.v b/test-suite/output/PrintModule.v
index 999d9a98..5f30f7cd 100644
--- a/test-suite/output/PrintModule.v
+++ b/test-suite/output/PrintModule.v
@@ -32,3 +32,19 @@ Module N : S with Module T := K := M.
 Print Module N.
 
 End BAR.
+
+Module QUX.
+
+Module Type Test.
+  Parameter t : Type.
+End Test.
+
+Module Type Func (T:Test).
+  Parameter x : T.t.
+End Func.
+
+Module Shortest_path (T : Test).
+Print Func.
+End Shortest_path.
+
+End QUX.
diff --git a/test-suite/output/Quote.out b/test-suite/output/Quote.out
index ca7fc362..998eb37c 100644
--- a/test-suite/output/Quote.out
+++ b/test-suite/output/Quote.out
@@ -8,17 +8,17 @@
   H : interp_f (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (f_atom End_idx) \/
       B
   ============================
-   interp_f
-     (Node_vm B (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (Empty_vm Prop))
-     (f_and (f_atom (Left_idx End_idx))
-        (f_and (f_or (f_atom End_idx) (f_atom (Left_idx End_idx)))
-           (f_or (f_atom (Left_idx End_idx)) (f_not (f_atom End_idx)))))
+  interp_f
+    (Node_vm B (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (Empty_vm Prop))
+    (f_and (f_atom (Left_idx End_idx))
+       (f_and (f_or (f_atom End_idx) (f_atom (Left_idx End_idx)))
+          (f_or (f_atom (Left_idx End_idx)) (f_not (f_atom End_idx)))))
 1 subgoal
   
   H : interp_f (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (f_atom End_idx) \/
       B
   ============================
-   interp_f (Node_vm B (Empty_vm Prop) (Empty_vm Prop))
-     (f_and (f_const A)
-        (f_and (f_or (f_atom End_idx) (f_const A))
-           (f_or (f_const A) (f_not (f_atom End_idx)))))
+  interp_f (Node_vm B (Empty_vm Prop) (Empty_vm Prop))
+    (f_and (f_const A)
+       (f_and (f_or (f_atom End_idx) (f_const A))
+          (f_or (f_const A) (f_not (f_atom End_idx)))))
diff --git a/test-suite/output/SearchPattern.out b/test-suite/output/SearchPattern.out
index 1eb7eca8..f3c12eff 100644
--- a/test-suite/output/SearchPattern.out
+++ b/test-suite/output/SearchPattern.out
@@ -40,7 +40,6 @@ Nat.land: nat -> nat -> nat
 Nat.lor: nat -> nat -> nat
 Nat.ldiff: nat -> nat -> nat
 Nat.lxor: nat -> nat -> nat
-
 S: nat -> nat
 Nat.succ: nat -> nat
 Nat.pred: nat -> nat
@@ -74,7 +73,6 @@ 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
diff --git a/test-suite/output/Tactics.out b/test-suite/output/Tactics.out
index 9949658c..239edd1d 100644
--- a/test-suite/output/Tactics.out
+++ b/test-suite/output/Tactics.out
@@ -1,4 +1,4 @@
 Ltac f H := split; [ a H | e H ]
 Ltac g := match goal with
-          | |- context [if ?X then _ else _] => case X
+          | |- context [ if ?X then _ else _ ] => case X
           end
diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out
index f2d14477..576fbd7c 100644
--- a/test-suite/output/inference.out
+++ b/test-suite/output/inference.out
@@ -6,13 +6,13 @@ fun e : option L => match e with
      : option L -> option L
 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
+fun n : nat => let x := A n : T n in ?y ?y0 : T n
      : forall n : nat, T n
 where
-?y : [n : nat  x := A n : T n |- ?T0 -> T n] 
-?y0 : [n : nat  x := A n : T n |- ?T0] 
+?y : [n : nat  x := A n : T n |- ?T -> T n] 
+?y0 : [n : nat  x := A n : T n |- ?T] 
 fun n : nat => ?y ?y0 : T n
      : forall n : nat, T n
 where
-?y : [n : nat |- ?T0 -> T n] 
-?y0 : [n : nat |- ?T0] 
+?y : [n : nat |- ?T -> T n] 
+?y0 : [n : nat |- ?T] 
diff --git a/test-suite/output/inference.v b/test-suite/output/inference.v
index cd9a4a12..1825db16 100644
--- a/test-suite/output/inference.v
+++ b/test-suite/output/inference.v
@@ -14,6 +14,7 @@ Definition P (e:option L) :=
 Print P.
 
 (* Check that plus is folded even if reduction is involved *)
+Set Refolding Reduction.
 Check (fun m n p (H : S m <= (S n) + p) => le_S_n _ _ H).
 
 
diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out
index d003c70d..1ff09e3a 100644
--- a/test-suite/output/ltac.out
+++ b/test-suite/output/ltac.out
@@ -1,2 +1,34 @@
 The command has indeed failed with message:
-Error: Ltac variable y depends on pattern variable name z which is not bound in current context.
+Error:
+Ltac variable y depends on pattern variable name z which is not bound in current context.
+Ltac f x y z :=
+  symmetry in x, y; auto with z; auto; intros **; clearbody x; generalize
+   dependent z
+The command has indeed failed with message:
+In nested Ltac calls to "g1" and "refine (uconstr)", last call failed.
+The term "I" has type "True" while it is expected to have type "False".
+The command has indeed failed with message:
+In nested Ltac calls to "f1 (constr)" and "refine (uconstr)", last call
+failed.
+The term "I" has type "True" while it is expected to have type "False".
+The command has indeed failed with message:
+In nested Ltac calls to "g2 (constr)", "g1" and "refine (uconstr)", last call
+failed.
+The term "I" has type "True" while it is expected to have type "False".
+The command has indeed failed with message:
+In nested Ltac calls to "f2", "f1 (constr)" and "refine (uconstr)", last call
+failed.
+The term "I" has type "True" while it is expected to have type "False".
+The command has indeed failed with message:
+In nested Ltac calls to "h" and "injection (destruction_arg)", last call
+failed.
+Error: No primitive equality found.
+The command has indeed failed with message:
+In nested Ltac calls to "h" and "injection (destruction_arg)", last call
+failed.
+Error: No primitive equality found.
+Hx
+nat
+nat
+0
+0
diff --git a/test-suite/output/ltac.v b/test-suite/output/ltac.v
index 7e2610c7..76c37625 100644
--- a/test-suite/output/ltac.v
+++ b/test-suite/output/ltac.v
@@ -15,3 +15,45 @@ lazymatch goal with
 | H1 : HT |- _ => idtac
 end.
 Abort.
+
+Ltac f x y z :=
+  symmetry in x, y;
+  auto with z;
+  auto;
+  intros;
+  clearbody x;
+  generalize dependent z.
+
+Print Ltac f.
+
+(* Error messages *)
+
+Ltac g1 x := refine x.
+Tactic Notation "g2" constr(x) := g1 x.
+Tactic Notation "f1" constr(x) := refine x.
+Ltac f2 x := f1 x.
+Goal False.
+Fail g1 I.
+Fail f1 I.
+Fail g2 I.
+Fail f2 I.
+
+Ltac h x := injection x.
+Goal True -> False.
+Fail h I.
+intro H.
+Fail h H.
+
+(* Check printing of the "var" argument "Hx" *)
+Ltac m H := idtac H; exact H.
+Goal True.
+let a:=constr:(let Hx := 0 in ltac:(m Hx)) in idtac.
+
+(* Check consistency of interpretation scopes (#4398) *)
+
+Goal nat*(0*0=0) -> nat*(0*0=0). intro.
+match goal with H: ?x*?y |- _ => idtac x end.
+match goal with |- ?x*?y => idtac x end.
+match goal with H: context [?x*?y] |- _ => idtac x end.
+match goal with |- context [?x*?y] => idtac x end.
+Abort.
diff --git a/test-suite/output/onlyprinting.out b/test-suite/output/onlyprinting.out
new file mode 100644
index 00000000..e0a30fcf
--- /dev/null
+++ b/test-suite/output/onlyprinting.out
@@ -0,0 +1,2 @@
+0:-) 0
+     : nat
diff --git a/test-suite/output/onlyprinting.v b/test-suite/output/onlyprinting.v
new file mode 100644
index 00000000..1973385a
--- /dev/null
+++ b/test-suite/output/onlyprinting.v
@@ -0,0 +1,5 @@
+Reserved Notation "x :-) y" (at level 50, only printing).
+
+Notation "x :-) y" := (plus x y).
+
+Check 0 + 0.
diff --git a/test-suite/output/qualification.out b/test-suite/output/qualification.out
new file mode 100644
index 00000000..9300c3f5
--- /dev/null
+++ b/test-suite/output/qualification.out
@@ -0,0 +1,3 @@
+File "stdin", line 19, characters 0-7:
+Error: Signature components for label test do not match: expected type
+"Top.M2.t = Top.M2.M.t" but found type "Top.M2.t = Top.M2.t".
diff --git a/test-suite/output/qualification.v b/test-suite/output/qualification.v
new file mode 100644
index 00000000..d39097e2
--- /dev/null
+++ b/test-suite/output/qualification.v
@@ -0,0 +1,19 @@
+Module Type T1.
+  Parameter t : Type.
+End T1.
+
+Module Type T2.
+  Declare Module M : T1.
+  Parameter t : Type.
+  Parameter test : t = M.t.
+End T2.
+
+Module M1 <: T1.
+  Definition t : Type := bool.
+End M1.
+
+Module M2 <: T2.
+  Module M := M1.
+  Definition t : Type := nat.
+  Lemma test : t = t. Proof. reflexivity. Qed.
+End M2.
diff --git a/test-suite/output/set.out b/test-suite/output/set.out
index 4dfd2bc2..4b72d73e 100644
--- a/test-suite/output/set.out
+++ b/test-suite/output/set.out
@@ -3,16 +3,16 @@
   y1 := 0 : nat
   x := 0 + 0 : nat
   ============================
-   x = x
+  x = x
 1 subgoal
   
   y1, y2 := 0 : nat
   x := y2 + 0 : nat
   ============================
-   x = x
+  x = x
 1 subgoal
   
   y1, y2, y3 := 0 : nat
   x := y2 + y3 : nat
   ============================
-   x = x
+  x = x
diff --git a/test-suite/output/simpl.out b/test-suite/output/simpl.out
index 73888da9..526e468f 100644
--- a/test-suite/output/simpl.out
+++ b/test-suite/output/simpl.out
@@ -2,14 +2,14 @@
   
   x : nat
   ============================
-   x = S x
+  x = S x
 1 subgoal
   
   x : nat
   ============================
-   0 + x = S x
+  0 + x = S x
 1 subgoal
   
   x : nat
   ============================
-   x = 1 + x
+  x = 1 + x
diff --git a/test-suite/output/subst.out b/test-suite/output/subst.out
new file mode 100644
index 00000000..209b2bc2
--- /dev/null
+++ b/test-suite/output/subst.out
@@ -0,0 +1,97 @@
+1 subgoal
+  
+  y, z : nat
+  Hy : y = 0
+  Hz : z = 0
+  H1 : 0 = 1
+  HA : True
+  H2 : 0 = 2
+  H3 : y = 3
+  HB : True
+  H4 : z = 4
+  ============================
+  True
+1 subgoal
+  
+  x, z : nat
+  Hx : x = 0
+  Hz : z = 0
+  H1 : x = 1
+  HA : True
+  H2 : x = 2
+  H3 : 0 = 3
+  HB : True
+  H4 : z = 4
+  ============================
+  True
+1 subgoal
+  
+  x, y : nat
+  Hx : x = 0
+  Hy : y = 0
+  H1 : x = 1
+  HA : True
+  H2 : x = 2
+  H3 : y = 3
+  HB : True
+  H4 : 0 = 4
+  ============================
+  True
+1 subgoal
+  
+  H1 : 0 = 1
+  HA : True
+  H2 : 0 = 2
+  H3 : 0 = 3
+  HB : True
+  H4 : 0 = 4
+  ============================
+  True
+1 subgoal
+  
+  y, z : nat
+  Hy : y = 0
+  Hz : z = 0
+  HA : True
+  H3 : y = 3
+  HB : True
+  H4 : z = 4
+  H1 : 0 = 1
+  H2 : 0 = 2
+  ============================
+  True
+1 subgoal
+  
+  x, z : nat
+  Hx : x = 0
+  Hz : z = 0
+  H1 : x = 1
+  HA : True
+  H2 : x = 2
+  HB : True
+  H4 : z = 4
+  H3 : 0 = 3
+  ============================
+  True
+1 subgoal
+  
+  x, y : nat
+  Hx : x = 0
+  Hy : y = 0
+  H1 : x = 1
+  HA : True
+  H2 : x = 2
+  H3 : y = 3
+  HB : True
+  H4 : 0 = 4
+  ============================
+  True
+1 subgoal
+  
+  HA, HB : True
+  H4 : 0 = 4
+  H3 : 0 = 3
+  H1 : 0 = 1
+  H2 : 0 = 2
+  ============================
+  True
diff --git a/test-suite/output/subst.v b/test-suite/output/subst.v
new file mode 100644
index 00000000..e48aa6bb
--- /dev/null
+++ b/test-suite/output/subst.v
@@ -0,0 +1,48 @@
+(* Ensure order of hypotheses is respected after "subst" *)
+
+Set Regular Subst Tactic.
+Goal forall x y z, x = 0 -> y = 0 -> z = 0 -> x = 1 -> True -> x = 2 -> y = 3 -> True -> z = 4 -> True.
+intros * Hx Hy Hz H1 HA H2 H3 HB H4.
+(* From now on, the order after subst is consistently H1, HA, H2, H3, HB, H4 *)
+subst x.
+(* In 8.4 or 8.5 without regular subst tactic mode, the order was HA, H3, HB, H4, H1, H2 *)
+Show.
+Undo.
+subst y.
+(* In 8.4 or 8.5 without regular subst tactic mode, the order was H1, HA, H2, HB, H4, H3 *)
+Show.
+Undo.
+subst z.
+(* In 8.4 or 8.5 without regular subst tactic mode, the order was H1, HA, H2, H3, HB, H4 *)
+Show.
+Undo.
+subst.
+(* In 8.4 or 8.5 without regular subst tactic mode, the order was HA, HB, H4, H3, H1, H2 *)
+(* In 8.5pl0 and 8.5pl1 with regular subst tactic mode, the order was HA, HB, H1, H2, H3, H4 *)
+Show.
+trivial.
+Qed.
+
+Unset Regular Subst Tactic.
+Goal forall x y z, x = 0 -> y = 0 -> z = 0 -> x = 1 -> True -> x = 2 -> y = 3 -> True -> z = 4 -> True.
+intros * Hx Hy Hz H1 HA H2 H3 HB H4.
+subst x.
+(* In 8.4 or 8.5 without regular subst tactic mode, the order was HA, H3, HB, H4, H1, H2 *)
+Show.
+Undo.
+subst y.
+(* In 8.4 or 8.5 without regular subst tactic mode, the order was H1, HA, H2, HB, H4, H3 *)
+Show.
+Undo.
+subst z.
+(* In 8.4 or 8.5 without regular subst tactic mode, the order was H1, HA, H2, H3, HB, H4 *)
+Show.
+Undo.
+subst.
+(* In 8.4 or 8.5 without regular subst tactic mode, the order was HA, HB, H4, H3, H1, H2 *)
+(* In 8.5pl0 and 8.5pl1 with regular subst tactic mode, the order was HA, HB, H1, H2, H3, H4 *)
+Show.
+trivial.
+Qed.
+
+
diff --git a/test-suite/output/unifconstraints.out b/test-suite/output/unifconstraints.out
new file mode 100644
index 00000000..ae846036
--- /dev/null
+++ b/test-suite/output/unifconstraints.out
@@ -0,0 +1,65 @@
+3 focused subgoals
+(shelved: 1)
+  
+  ============================
+  ?Goal 0
+
+subgoal 2 is:
+ forall n : nat, ?Goal n -> ?Goal (S n)
+subgoal 3 is:
+ nat
+unification constraint:
+ ?Goal ?Goal2 <=
+   True /\ True /\ True \/
+   veeryyyyyyyyyyyyloooooooooooooonggidentifier =
+   veeryyyyyyyyyyyyloooooooooooooonggidentifier
+3 focused subgoals
+(shelved: 1)
+  
+  n, m : nat
+  ============================
+  ?Goal@{n:=n; m:=m} 0
+
+subgoal 2 is:
+ forall n0 : nat, ?Goal@{n:=n; m:=m} n0 -> ?Goal@{n:=n; m:=m} (S n0)
+subgoal 3 is:
+ nat
+unification constraint:
+ ?Goal@{n:=n; m:=m} ?Goal2@{n:=n; m:=m} <=
+   True /\ True /\ True \/
+   veeryyyyyyyyyyyyloooooooooooooonggidentifier =
+   veeryyyyyyyyyyyyloooooooooooooonggidentifier
+3 focused subgoals
+(shelved: 1)
+  
+  m : nat
+  ============================
+  ?Goal1@{m:=m} 0
+
+subgoal 2 is:
+ forall n0 : nat, ?Goal1@{m:=m} n0 -> ?Goal1@{m:=m} (S n0)
+subgoal 3 is:
+ nat
+unification constraint:
+ 
+ n, m : nat |- ?Goal1@{m:=m} ?Goal0@{n:=n; m:=m} <=
+   True /\ True /\ True \/
+   veeryyyyyyyyyyyyloooooooooooooonggidentifier =
+   veeryyyyyyyyyyyyloooooooooooooonggidentifier
+3 focused subgoals
+(shelved: 1)
+  
+  m : nat
+  ============================
+  ?Goal0@{m:=m} 0
+
+subgoal 2 is:
+ forall n0 : nat, ?Goal0@{m:=m} n0 -> ?Goal0@{m:=m} (S n0)
+subgoal 3 is:
+ nat
+unification constraint:
+ 
+ n, m : nat |- ?Goal0@{m:=m} ?Goal2@{n:=n} <=
+   True /\ True /\ True \/
+   veeryyyyyyyyyyyyloooooooooooooonggidentifier =
+   veeryyyyyyyyyyyyloooooooooooooonggidentifier
diff --git a/test-suite/output/unifconstraints.v b/test-suite/output/unifconstraints.v
new file mode 100644
index 00000000..b9413a4a
--- /dev/null
+++ b/test-suite/output/unifconstraints.v
@@ -0,0 +1,22 @@
+(* Set Printing Existential Instances. *)
+Unset Solve Unification Constraints.
+Axiom veeryyyyyyyyyyyyloooooooooooooonggidentifier : nat.
+Goal True /\ True /\ True \/
+             veeryyyyyyyyyyyyloooooooooooooonggidentifier =
+             veeryyyyyyyyyyyyloooooooooooooonggidentifier.
+  refine (nat_rect _ _ _ _).
+  Show.
+Admitted.
+
+Set Printing Existential Instances.
+Goal forall n m : nat, True /\ True /\ True \/
+                        veeryyyyyyyyyyyyloooooooooooooonggidentifier =
+                        veeryyyyyyyyyyyyloooooooooooooonggidentifier.
+  intros.
+  refine (nat_rect _ _ _ _).
+  Show.
+  clear n. 
+  Show.
+  3:clear m.
+  Show.
+Admitted.
diff --git a/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v
index 0d75d52a..06357cfc 100644
--- a/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v
+++ b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v
@@ -1902,14 +1902,14 @@ 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.
+ intros [|p1|p1]; [intros y|intros [|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;
+ intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H;
   try discriminate H; [ left | right ]; repeat split.
 Qed. 
 
@@ -1917,13 +1917,13 @@ 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;
+ intros [|p1|p1]; [intros y|intros [|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;
+ intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H;
   try discriminate H; [ left | right | right ]; constructor.
 Qed. 
 
@@ -1932,40 +1932,40 @@ 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;
+ intros [|p1|p1]; [intros y|intros [|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;
+ intros [|p1|p1]; [intros y|intros [|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;
+ intros [|p1|p1]; [intros y|intros [|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;
+ intros [|p1|p1]; [intros y|intros [|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 [|p1|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 [|p1|p1] [|p2|p2]; simpl in |- *;
   intros H H0; discriminate H || discriminate H0.
 Qed.
 
diff --git a/test-suite/success/Case13.v b/test-suite/success/Case13.v
index f14725a8..8f95484c 100644
--- a/test-suite/success/Case13.v
+++ b/test-suite/success/Case13.v
@@ -55,6 +55,14 @@ Check (fun x : I' 0 => match x with
                        | _ => 0
                        end).
 
+(* This one could eventually be solved, the "Fail" is just to ensure *)
+(* that it does not fail with an anomaly, as it did at some time *)
+Fail Check (fun x : I' 0 => match x return _ x with
+                       | C2' _ _ => 0
+                       | niln => 0
+                       | _ => 0
+                       end).
+
 (* Check insertion of coercions around matched subterm *)
 
 Parameter A:Set.
diff --git a/test-suite/success/CaseInClause.v b/test-suite/success/CaseInClause.v
index 3679eead..6424fe92 100644
--- a/test-suite/success/CaseInClause.v
+++ b/test-suite/success/CaseInClause.v
@@ -20,3 +20,10 @@ Theorem foo : forall (n m : nat) (pf : n = m),
                 match pf in _ = N with 
                   | eq_refl => unit
                 end.
+
+(* Check redundant clause is removed *)
+Inductive I : nat * nat -> Type := C : I (0,0).
+Check fun x : I (1,1) => match x in I (y,z) return y = z with C => eq_refl end.
+
+(* An example of non-local inference of the type of an impossible case *)
+Check (fun y n (x:Vector.t nat (S n)) => match x with a::_ => a | _ => y end) 2.
diff --git a/test-suite/success/Compat84.v b/test-suite/success/Compat84.v
new file mode 100644
index 00000000..db6348fa
--- /dev/null
+++ b/test-suite/success/Compat84.v
@@ -0,0 +1,19 @@
+(* -*- coq-prog-args: ("-emacs" "-compat" "8.4") -*- *)
+
+Goal True.
+  solve [ constructor 1 ]. Undo.
+  solve [ econstructor 1 ]. Undo.
+  solve [ constructor ]. Undo.
+  solve [ econstructor ]. Undo.
+  solve [ constructor (fail) ]. Undo.
+  solve [ econstructor (fail) ]. Undo.
+  split.
+Qed.
+
+Goal False \/ True.
+  solve [ constructor (constructor) ]. Undo.
+  solve [ econstructor (econstructor) ]. Undo.
+  solve [ constructor 2; constructor ]. Undo.
+  solve [ econstructor 2; econstructor ]. Undo.
+  right; esplit.
+Qed.
diff --git a/test-suite/success/Hints.v b/test-suite/success/Hints.v
index f934a5c7..1abe1477 100644
--- a/test-suite/success/Hints.v
+++ b/test-suite/success/Hints.v
@@ -1,4 +1,12 @@
 (* Checks syntax of Hints commands *)
+(* Old-style syntax *)
+Hint Resolve eq_refl eq_sym.
+Hint Resolve eq_refl eq_sym: foo.
+Hint Immediate eq_refl eq_sym.
+Hint Immediate eq_refl eq_sym: foo.
+Hint Unfold fst eq_sym.
+Hint Unfold fst eq_sym: foo.
+
 (* Checks that qualified names are accepted *)
 
 (* New-style syntax *)
@@ -8,13 +16,76 @@ Hint Unfold eq_sym: core.
 Hint Constructors eq: foo bar.
 Hint Extern 3 (_ = _) => apply eq_refl: foo bar.
 
-(* Old-style syntax *)
-Hint Resolve eq_refl eq_sym.
-Hint Resolve eq_refl eq_sym: foo.
-Hint Immediate eq_refl eq_sym.
-Hint Immediate eq_refl eq_sym: foo.
-Hint Unfold fst eq_sym.
-Hint Unfold fst eq_sym: foo.
+(* Extended new syntax with patterns *)
+Hint Resolve eq_refl | 4 (_ = _) : baz.
+Hint Resolve eq_sym eq_trans : baz.
+Hint Extern 3 (_ = _) => apply eq_sym : baz.
+
+Parameter pred : nat -> Prop.
+Parameter pred0 : pred 0.
+Parameter f : nat -> nat.
+Parameter predf : forall n, pred n -> pred (f n).
+
+(* No conversion on let-bound variables and constants in pred (the default) *)
+Hint Resolve pred0 | 1 (pred _) : pred.
+Hint Resolve predf | 0 : pred.
+
+(* Allow full conversion on let-bound variables and constants *)
+Create HintDb predconv discriminated.
+Hint Resolve pred0 | 1 (pred _) : predconv.
+Hint Resolve predf | 0 : predconv.
+
+Goal exists n, pred n.
+  eexists.
+  Fail Timeout 1 typeclasses eauto with pred.
+  Set Typeclasses Filtered Unification.
+  Set Typeclasses Debug Verbosity 2.
+  (* predf is not tried as it doesn't match the goal *)
+  typeclasses eauto with pred.
+Qed.
+
+Parameter predconv : forall n, pred n -> pred (0 + S n).
+
+(* The inferred pattern contains 0 + ?n, syntactic match will fail to see convertible
+ terms *)
+Hint Resolve pred0 : pred2.
+Hint Resolve predconv : pred2.
+
+(** In this database we allow predconv to apply to pred (S _) goals, more generally
+  than the inferred pattern (pred (0 + S _)). *)
+Create HintDb pred2conv discriminated.
+Hint Resolve pred0 : pred2conv.
+Hint Resolve predconv | 1 (pred (S _)) : pred2conv.
+
+Goal pred 3.
+  Fail typeclasses eauto with pred2.
+  typeclasses eauto with pred2conv.
+Abort.
+
+Set Typeclasses Filtered Unification.
+Set Typeclasses Debug Verbosity 2.
+Hint Resolve predconv | 1 (pred _) : pred.
+Hint Resolve predconv | 1 (pred (S _)) : predconv.
+Test Typeclasses Limit Intros.
+Goal pred 3.
+  (* predf is not tried as it doesn't match the goal *)
+  (* predconv is tried but fails as the transparent state doesn't allow
+     unfolding + *)
+  Fail typeclasses eauto with pred.
+  (* Here predconv succeeds as it matches (pred (S _)) and then
+     full unification is allowed *)
+  typeclasses eauto with predconv.
+Qed.
+
+(** The other way around: goal contains redexes instead of instances *)
+Goal exists n, pred (0 + n).
+  eexists.
+  (* predf is applied indefinitely *)
+  Fail Timeout 1 typeclasses eauto with pred.
+  (* pred0 (pred _) matches the goal *)
+  typeclasses eauto with predconv.
+Qed.
+
 
 (* Checks that local names are accepted *)
 Section A.
@@ -100,9 +171,9 @@ Instance foo f :
 Proof.
   Fail Timeout 1 apply _. (* 3.7s *)
   
-Hint Cut [!*; (a_is_b | b_is_c | c_is_d | d_is_e) ;
-  (a_compose | b_compose | c_compose | d_compose | e_compose)] : typeclass_instances.
+Hint Cut [_* (a_is_b | b_is_c | c_is_d | d_is_e)
+                 (a_compose | b_compose | c_compose | d_compose | e_compose)] : typeclass_instances.
 
   Timeout 1 Fail apply _. (* 0.06s *)
 Abort.
-End HintCut.
\ No newline at end of file
+End HintCut.
diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v
index 9661b3bf..f746def5 100644
--- a/test-suite/success/Inductive.v
+++ b/test-suite/success/Inductive.v
@@ -162,3 +162,24 @@ Inductive L (A:Type) (T:=A) : Type := C : L nat -> L A.
    hit the Inductiveops.get_arity bug mentioned above (see #3491) *)
 
 Inductive IND6 (A:Type) (T:=A) := CONS6 : IND6 T -> IND6 A.
+
+
+Module TemplateProp.
+
+  (** Check lowering of a template universe polymorphic inductive to Prop *)
+  
+  Inductive Foo (A : Type) : Type := foo : A -> Foo A.
+  
+  Check Foo True : Prop.
+
+End TemplateProp.
+
+Module PolyNoLowerProp.
+
+  (** Check lowering of a general universe polymorphic inductive to Prop is _failing_ *)
+  
+  Polymorphic Inductive Foo (A : Type) : Type := foo : A -> Foo A.
+  
+  Fail Check Foo True : Prop.
+
+End PolyNoLowerProp.
diff --git a/test-suite/success/Injection.v b/test-suite/success/Injection.v
index 25e464d6..da218384 100644
--- a/test-suite/success/Injection.v
+++ b/test-suite/success/Injection.v
@@ -4,6 +4,7 @@ Require Eqdep_dec.
 
 (* Check that Injection tries Intro until *)
 
+Unset Structural Injection.
 Lemma l1 : forall x : nat, S x = S (S x) -> False.
  injection 1.
 apply n_Sn.
@@ -37,6 +38,7 @@ intros.
  injection H.
 exact (fun H => H).
 Qed.
+Set Structural Injection.
 
 (* Test injection as *)
 
@@ -65,7 +67,13 @@ Qed.
 Goal (forall x y : nat, x = y -> S x = S y) -> True.
 intros.
 einjection (H O).
-instantiate (1:=O).
+2:instantiate (1:=O).
+Abort.
+
+Goal (forall x y : nat, x = y -> S x = S y) -> True.
+intros.
+einjection (H O ?[y]) as H0.
+instantiate (y:=O).
 Abort.
 
 (* Test the injection intropattern *)
@@ -79,12 +87,21 @@ Qed.
 (* Basic case, using sigT *)
 
 Scheme Equality for nat.
+Unset Structural Injection.
 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.
+Set Structural Injection.
+
+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 H0.
+exact H0.
+Abort.
 
 (* Test injection using K, knowing that an equality is decidable *)
 (* Basic case, using sigT, with "as" clause *)
@@ -118,7 +135,22 @@ intros * [= H].
 exact H.
 Abort.
 
-(* Injection does not projects at positions in Prop... allow it?
+(* Test the Keep Proof Equalities option. *)
+Set Keep Proof Equalities.
+Unset Structural Injection.
+
+Inductive pbool : Prop := Pbool1 | Pbool2.
+
+Inductive pbool_shell : Set := Pbsc : pbool -> pbool_shell.
+
+Goal Pbsc Pbool1 = Pbsc Pbool2 -> True.
+injection 1.
+match goal with
+ |- Pbool1 = Pbool2 -> True => idtac | |- True => fail
+end.
+Abort.
+
+(* Injection does not project at positions in Prop... allow it?
 
 Inductive t (A:Prop) : Set := c : A -> t A.
 Goal forall p q : True\/True, c _ p = c _ q -> False.
diff --git a/test-suite/success/MatchFail.v b/test-suite/success/MatchFail.v
index 7069bba4..8462d362 100644
--- a/test-suite/success/MatchFail.v
+++ b/test-suite/success/MatchFail.v
@@ -9,14 +9,14 @@ Require Export ZArithRing.
 Ltac compute_POS :=
   match goal with
   |  |- context [(Zpos (xI ?X1))] =>
-      let v := constr:X1 in
-      match constr:v with
+      let v := constr:(X1) in
+      match constr:(v) with
       | 1%positive => fail 1
       | _ =>  rewrite (BinInt.Pos2Z.inj_xI v)
       end
   |  |- context [(Zpos (xO ?X1))] =>
-      let v := constr:X1 in
-      match constr:v with
+      let v := constr:(X1) in
+      match constr:(v) with
       | 1%positive => fail 1
       | _ =>  rewrite (BinInt.Pos2Z.inj_xO v)
       end
diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v
index b72a0674..07bbb60c 100644
--- a/test-suite/success/Notations.v
+++ b/test-suite/success/Notations.v
@@ -58,7 +58,7 @@ Check (fun x:nat*nat => match x with R x y => (x,y) end).
 
 (* Check multi-tokens recursive notations *)
 
-Local Notation "[ a  # ; ..  # ; b ]" := (a + .. (b + 0) ..).   
+Local Notation "[ a  # ; ..  # ; b ]" := (a + .. (b + 0) ..).
 Check [ 0 ].
 Check [ 0 # ; 1 ].
 
@@ -107,3 +107,24 @@ Notation traverse_var f l := (traverse (fun l => f l) l).
 
 Notation "'intros' x" := (S x) (at level 0).
 Goal True -> True. intros H. exact H. Qed.
+
+(* Check absence of collision on ".." in nested notations with ".." *)
+Notation "[ a , .. , b ]" := (a, (.. (b,tt) ..)).
+
+(* Check that vector notations do not break Ltac [] (bugs #4785, #4733) *)
+Require Import Coq.Vectors.VectorDef.
+Import VectorNotations.
+Goal True. idtac; []. (* important for test: no space here *) constructor. Qed.
+
+(* Check parsing of { and } is not affected by notations #3479 *)
+Notation " |- {{ a }} b" := (a=b) (no associativity, at level 10).
+Goal True.
+{{ exact I. }}
+Qed.
+Check |- {{ 0 }} 0.
+
+(* Check parsing of { and } is not affected by notations #3479 *)
+Notation " |- {{ a }} b" := (a=b) (no associativity, at level 10).
+Goal True.
+{{ exact I. }}
+Qed.
diff --git a/test-suite/success/Notations2.v b/test-suite/success/Notations2.v
new file mode 100644
index 00000000..9505a56e
--- /dev/null
+++ b/test-suite/success/Notations2.v
@@ -0,0 +1,92 @@
+(* This file is giving some examples about how implicit arguments and
+   scopes are treated when using abbreviations or notations, in terms
+   or patterns, or when using @ and parentheses in terms and patterns.
+
+The convention is:
+
+Constant foo with implicit arguments and scopes used in a term or a pattern:
+
+       foo      do not deactivate further arguments and scopes
+       @foo     deactivates further arguments and scopes
+       (foo x)  deactivates further arguments and scopes
+       (@foo x) deactivates further arguments and scopes
+
+Notations binding to foo:
+
+#   := foo      do not deactivate further arguments and scopes
+#   := @foo     deactivates further arguments and scopes
+# x := foo x    deactivates further arguments and scopes
+# x := @foo x   deactivates further arguments and scopes
+
+Abbreviations binding to foo:
+
+f   := foo      do not deactivate further arguments and scopes
+f   := @foo     deactivates further arguments and scopes
+f x := foo x    do not deactivate further arguments and scopes
+f x := @foo x   do not deactivate further arguments and scopes
+*)
+
+(* One checks that abbreviations and notations in patterns now behave like in terms *)
+
+Inductive prod' A : Type -> Type :=
+| pair' (a:A) B (b:B) (c:bool) : prod' A B.
+Arguments pair' [A] a%bool_scope [B] b%bool_scope c%bool_scope.
+Notation "0" := true : bool_scope.
+
+(* 1. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *)
+Notation c1 x := (pair' x).
+Check pair' 0 0 0 : prod' bool bool.
+Check (pair' 0) _ 0%bool 0%bool : prod' bool bool. (* parentheses are blocking implicit and scopes *)
+Check c1 0 0 0 : prod' bool bool.
+Check fun x : prod' bool bool => match x with c1 0 y 0 => 2 | _ => 1 end.
+
+(* 2. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *)
+Notation c2 x := (@pair' _ x).
+Check (@pair' _ 0) _ 0%bool 0%bool : prod' bool bool. (* parentheses are blocking implicit and scopes *)
+Check c2 0 0 0 : prod' bool bool.
+Check fun A (x : prod' bool A) => match x with c2 0 y 0 => 2 | _ => 1 end.
+Check fun A (x : prod' bool A) => match x with (@pair' _ 0) _ y 0%bool => 2 | _ => 1 end.
+
+(* 3. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *)
+Notation c3 x := ((@pair') _ x).
+Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. (* @ is blocking implicit and scopes *)
+Check ((@pair') _ 0%bool) _ 0%bool 0%bool : prod' bool bool. (* parentheses and @ are blocking implicit and scopes *)
+Check c3 0 0 0 : prod' nat bool. (* First scope is blocked but not the last two scopes *)
+Check fun A (x :prod' nat A) => match x with c3 0 y 0 => 2 | _ => 1 end.
+
+(* 4. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *)
+(* unless an atomic @ is given *)
+Notation c4 := (@pair').
+Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool.
+Check c4 _ 0%bool _ 0%bool 0%bool : prod' bool bool.
+Check fun A (x :prod' bool A) => match x with c4 _ 0%bool _ y 0%bool => 2 | _ => 1 end.
+Check fun A (x :prod' bool A) => match x with (@pair') _ 0%bool _ y 0%bool => 2 | _ => 1 end.
+
+(* 5. Notations stop further implicit arguments to be inserted and scopes to be used *)
+Notation "# x" := (pair' x) (at level 0, x at level 1).
+Check pair' 0 0 0 : prod' bool bool.
+Check # 0 _ 0%bool 0%bool : prod' bool bool.
+Check fun A (x :prod' bool A) => match x with # 0 _ y 0%bool => 2 | _ => 1 end.
+
+(* 6. Notations stop further implicit arguments to be inserted and scopes to be used *)
+Notation "## x" := ((@pair') _ x) (at level 0, x at level 1).
+Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool.
+Check ((@pair') _ 0%bool) _ 0%bool 0%bool : prod' bool bool.
+Check ## 0%bool _ 0%bool 0%bool : prod' bool bool.
+Check fun A (x :prod' bool A) => match x with ## 0%bool _ y 0%bool => 2 | _ => 1 end.
+
+(* 7. Notations stop further implicit arguments to be inserted and scopes to be used *)
+Notation "###" := (@pair') (at level 0).
+Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool.
+Check ### _ 0%bool _ 0%bool 0%bool : prod' bool bool.
+Check fun A (x :prod' bool A) => match x with ### _ 0%bool _ y 0%bool => 2 | _ => 1 end.
+
+(* 8. Notations w/o @ preserves implicit arguments and scopes *)
+Notation "####" := pair' (at level 0).
+Check #### 0 0 0 : prod' bool bool.
+Check fun A (x :prod' bool A) => match x with #### 0 y 0 => 2 | _ => 1 end.
+
+(* 9. Notations w/o @ but arguments do not preserve further implicit arguments and scopes *)
+Notation "##### x" := (pair' x) (at level 0, x at level 1).
+Check ##### 0 _ 0%bool 0%bool : prod' bool bool.
+Check fun A (x :prod' bool A) => match x with ##### 0 _ y 0%bool => 2 | _ => 1 end.
diff --git a/test-suite/success/PatternsInBinders.v b/test-suite/success/PatternsInBinders.v
new file mode 100644
index 00000000..77710791
--- /dev/null
+++ b/test-suite/success/PatternsInBinders.v
@@ -0,0 +1,67 @@
+(** The purpose of this file is to test functional properties of the
+    destructive patterns used in binders ([fun] and [forall]). *)
+
+
+Definition swap {A B} '((x,y) : A*B) := (y,x).
+
+(** Tests the use of patterns in [fun] and [Definition] *)
+Section TestFun.
+
+  Variables A B : Type.
+
+  Goal forall (x:A) (y:B), swap (x,y) = (y,x).
+  Proof. reflexivity. Qed.
+
+  Goal forall u:A*B, swap (swap u) = u.
+  Proof. destruct u. reflexivity. Qed.
+
+  Goal @swap A B = fun '(x,y) => (y,x).
+  Proof. reflexivity. Qed.
+
+End TestFun.
+
+
+(** Tests the use of patterns in [forall] *)
+Section TestForall.
+
+  Variables A B : Type.
+
+  Goal forall '((x,y) : A*B), swap (x,y) = (y,x).
+  Proof. intros [x y]. reflexivity. Qed.
+
+  Goal forall x0:A, exists '((x,y) : A*A), swap (x,y) = (x,y).
+  Proof.
+    intros x0.
+    exists (x0,x0).
+    reflexivity.
+  Qed.
+
+End TestForall.
+
+
+
+(** Tests the use of patterns in dependent definitions. *)
+
+Section TestDependent.
+
+  Inductive Fin (n:nat) := Z : Fin n.
+
+  Definition F '(n,p) : Type := (Fin n * Fin p)%type.
+
+  Definition both_z '(n,p) : F (n,p) := (Z _,Z _).
+
+End TestDependent.
+
+
+(** Tests with a few other types just to make sure parsing is
+    robust. *)
+Section TestExtra.
+
+  Definition proj_informative {A P} '(exist _ x _ : { x:A | P x }) : A := x.
+
+  Inductive Foo := Bar : nat -> bool -> unit -> nat -> Foo.
+
+  Definition foo '(Bar n b tt p) :=
+    if b then n+p else n-p.
+
+End TestExtra.
diff --git a/test-suite/success/RecTutorial.v b/test-suite/success/RecTutorial.v
index 11fbf24d..d8f80424 100644
--- a/test-suite/success/RecTutorial.v
+++ b/test-suite/success/RecTutorial.v
@@ -831,7 +831,7 @@ Proof.
  intro n.
  apply nat_ind with (P:= fun n => n <> S n).
  discriminate.
- red; intros n0 Hn0 eqn0Sn0;injection eqn0Sn0;trivial.
+ red; intros n0 Hn0 eqn0Sn0;injection eqn0Sn0;auto.
 Qed.
 
 Definition eq_nat_dec : forall n p:nat , {n=p}+{n <> p}.
@@ -1075,8 +1075,8 @@ Proof.
  apply vector_double_rect.
  simpl.
  destruct i; discriminate 1.
- destruct i; simpl;auto.
- injection 1; injection 2;intros; subst a; subst b; auto.
+ destruct i; simpl;auto. 
+ injection 1 as ->; injection 1 as ->; auto.
 Qed.
 
  Set Implicit Arguments.
diff --git a/test-suite/success/TacticNotation2.v b/test-suite/success/TacticNotation2.v
new file mode 100644
index 00000000..cb341b8e
--- /dev/null
+++ b/test-suite/success/TacticNotation2.v
@@ -0,0 +1,12 @@
+Tactic Notation "complete" tactic(tac) := tac; fail.
+
+Ltac f0 := complete (intuition idtac).
+(** FIXME: This is badly printed because of bug #3079.
+    At least we check that it does not fail anomalously. *)
+Print Ltac f0.
+
+Ltac f1 := complete f1.
+Print Ltac f1.
+
+Ltac f2 := complete intuition.
+Print Ltac f2.
diff --git a/test-suite/success/TestRefine.v b/test-suite/success/TestRefine.v
index c8a8b862..023cb5f5 100644
--- a/test-suite/success/TestRefine.v
+++ b/test-suite/success/TestRefine.v
@@ -53,7 +53,7 @@ Abort.
 
 Lemma essai2 : forall x : nat, x = x.
 
-Fail refine (fix f (x : nat) : x = x := _).
+refine (fix f (x : nat) : x = x := _).
 
 Restart.
 
diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v
index 30a2a742..6b1f0315 100644
--- a/test-suite/success/Typeclasses.v
+++ b/test-suite/success/Typeclasses.v
@@ -1,3 +1,117 @@
+Module onlyclasses.
+
+(* In 8.6 we still allow non-class subgoals *)
+  Variable Foo : Type.
+  Variable foo : Foo.
+  Hint Extern 0 Foo => exact foo : typeclass_instances.
+  Goal Foo * Foo.
+    split. shelve.
+    Set Typeclasses Debug.
+    typeclasses eauto.
+    Unshelve. typeclasses eauto.
+  Qed.
+
+  Module RJung.
+    Class Foo (x : nat).
+      
+      Instance foo x : x = 2 -> Foo x.
+      Hint Extern 0 (_ = _) => reflexivity : typeclass_instances.
+      Typeclasses eauto := debug.
+      Check (_ : Foo 2).
+
+
+      Fail Definition foo := (_ : 0 = 0).
+
+  End RJung.
+End onlyclasses.
+
+Module shelve_non_class_subgoals.
+  Variable Foo : Type.
+  Variable foo : Foo.
+  Hint Extern 0 Foo => exact foo : typeclass_instances.
+  Class Bar := {}.
+  Instance bar1 (f:Foo) : Bar := {}.
+
+  Typeclasses eauto := debug.
+  Set Typeclasses Debug Verbosity 2.
+  Goal Bar.
+    (* Solution has shelved subgoals (of non typeclass type) *)
+    typeclasses eauto.
+  Abort.
+End shelve_non_class_subgoals.
+
+Module RefineVsNoTceauto.
+
+  Class Foo (A : Type) := foo : A.
+  Instance: Foo nat := { foo := 0 }.
+  Instance: Foo nat := { foo := 42 }.
+  Hint Extern 0 (_ = _) => refine eq_refl : typeclass_instances.
+  Goal exists (f : Foo nat), @foo _ f = 0.
+  Proof.
+    unshelve (notypeclasses refine (ex_intro _ _ _)). 
+    Set Typeclasses Debug. Set Printing All.
+    all:once (typeclasses eauto).
+    Fail idtac. (* Check no subgoals are left *)
+    Undo 3.
+    (** In this case, the (_ = _) subgoal is not considered 
+        by typeclass resolution *)
+    refine (ex_intro _ _ _). Fail reflexivity.
+  Abort.
+
+End RefineVsNoTceauto.
+
+Module Leivantex2PR339.
+  (** Was a bug preventing to find hints associated with no pattern *)
+  Class Bar := {}.
+  Instance bar1 (t:Type) : Bar.
+  Hint Extern 0 => exact True : typeclass_instances.
+  Typeclasses eauto := debug.
+  Goal Bar.
+    Set Typeclasses Debug Verbosity 2.
+    typeclasses eauto. (* Relies on resolution of a non-class subgoal *)
+    Undo 1.
+    typeclasses eauto with typeclass_instances.
+  Qed.
+End Leivantex2PR339.
+
+Module bt.
+Require Import Equivalence.
+
+Record Equ (A : Type) (R : A -> A -> Prop).
+Definition equiv {A} R (e : Equ A R) := R.
+Record Refl (A : Type) (R : A -> A -> Prop).
+Axiom equ_refl : forall A R (e : Equ A R), Refl _ (@equiv A R e).
+Hint Extern 0 (Refl _ _) => unshelve class_apply @equ_refl; [shelve|] : foo.
+
+Variable R : nat -> nat -> Prop.
+Lemma bas : Equ nat R.
+Admitted.
+Hint Resolve bas : foo.
+Hint Extern 1 => match goal with |- (_ -> _ -> Prop) => shelve end : foo.
+
+Goal exists R, @Refl nat R.
+  eexists.
+  Set Typeclasses Debug.
+  (* Fail solve [unshelve eauto with foo]. *)
+  Set Typeclasses Debug Verbosity 1.
+  Test Typeclasses Depth.
+  solve [typeclasses eauto with foo].
+Qed.
+
+Set Typeclasses Compatibility "8.5".
+Parameter f : nat -> Prop.
+Parameter g : nat -> nat -> Prop.
+Parameter h : nat -> nat -> nat -> Prop.
+Axiom a : forall x y, g x y -> f x -> f y.
+Axiom b : forall x (y : Empty_set), g (fst (x,y)) x.
+Axiom c : forall x y z, h x y z -> f x -> f y.
+Hint Resolve a b c : mybase.
+Goal forall x y z, h x y z -> f x -> f y.
+  intros.
+  Fail Timeout 1 typeclasses eauto with mybase. (* Loops now *)
+  Unshelve.
+Abort.
+End bt.
 Generalizable All Variables.
 
 Module mon.
@@ -23,8 +137,15 @@ Notation "'return' t" := (unit t).
 Class A `(e: T) := { a := True }.
 Class B `(e_: T) := { e := e_; sg_ass :> A e }.
 
-Goal forall `{B T}, a.
-  intros. exact I.
+(* Set Typeclasses Debug. *)
+(* Set Typeclasses Debug Verbosity 2. *)
+
+Goal forall `{B T}, Prop.
+  intros. apply a.
+Defined.
+
+Goal forall `{B T}, Prop.
+  intros. refine (@a _ _ _).
 Defined.
 
 Class B' `(e_: T) := { e' := e_; sg_ass' :> A e_ }.
@@ -57,4 +178,65 @@ Section sec.
  let's try to get rid of the intermediate constant foo.
  Surely we can just expand it inline, right? Wrong!: *)
  Check U (fun x => e x) _.
-End sec.
\ No newline at end of file
+End sec.
+
+Module UniqueSolutions.
+  Set Typeclasses Unique Solutions.
+  Class Eq (A : Type) : Set.
+    Instance eqa : Eq nat := {}.
+    Instance eqb : Eq nat := {}.
+
+    Goal Eq nat.
+      try apply _.
+      Fail exactly_once typeclasses eauto.
+    Abort.
+End UniqueSolutions.
+
+
+Module UniqueInstances.
+  (** Optimize proof search on this class by never backtracking on (closed) goals
+      for it. *)
+  Set Typeclasses Unique Instances.
+  Class Eq (A : Type) : Set.
+    Instance eqa : Eq nat := _. constructor. Qed.
+    Instance eqb : Eq nat := {}.
+    Class Foo (A : Type) (e : Eq A) : Set.
+    Instance fooa : Foo _ eqa := {}.
+
+    Tactic Notation "refineu" open_constr(c) := unshelve refine c.
+
+    Set Typeclasses Debug.
+    Goal { e : Eq nat & Foo nat e }.
+      unshelve refineu (existT _ _ _).
+      all:simpl.
+      (** Does not backtrack on the (wrong) solution eqb *)
+      Fail all:typeclasses eauto.
+    Abort.
+End UniqueInstances.
+
+Module IterativeDeepening.
+
+  Class A.
+  Class B.
+  Class C.
+
+  Instance: B -> A | 0.
+  Instance: C -> A | 0.
+  Instance: C -> B -> A | 0.
+  Instance: A -> A | 0.
+  
+  Goal C -> A.
+    intros.
+    Set Typeclasses Debug.
+    Fail Timeout 1 typeclasses eauto.
+    Set Typeclasses Iterative Deepening.
+    Fail typeclasses eauto 1.
+    typeclasses eauto 2.
+    Undo.
+    Unset Typeclasses Iterative Deepening.
+    Fail Timeout 1 typeclasses eauto.
+    Set Typeclasses Iterative Deepening.
+    typeclasses eauto.
+  Qed.
+
+End IterativeDeepening.
diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v
index 55b666b7..02e043bc 100644
--- a/test-suite/success/apply.v
+++ b/test-suite/success/apply.v
@@ -543,7 +543,7 @@ Qed.
 Lemma bar (X: nat -> nat -> Prop) (foo:forall x, X x x) (a: unit) (H: tt = a):
   exists x, exists y, X x y.
 Proof.
-intros; eexists; eexists; case H.
+intros; eexists; eexists ?[y]; case H.
 apply (foo ?y).
 Grab Existential Variables.
 exact 0.
diff --git a/test-suite/success/auto.v b/test-suite/success/auto.v
index aaa7b3a5..5477c833 100644
--- a/test-suite/success/auto.v
+++ b/test-suite/success/auto.v
@@ -45,3 +45,92 @@ Proof.
   eexists. Fail progress debug eauto with test2. 
   progress eauto with test.
 Qed.
+
+(** Patterns of Extern have a "matching" semantics.
+    It is not so for apply/exact hints *)
+
+Class B (A : Type).
+Class I. 
+Instance i : I.
+  
+Definition flip {A B C : Type} (f : A -> B -> C) := fun y x => f x y.
+Class D (f : nat -> nat -> nat).
+Definition ftest (x y : nat) := x + y.
+Definition flipD (f : nat -> nat -> nat) : D f -> D (flip f).
+  Admitted.
+Module Instnopat.
+  Local Instance: B nat.
+  (* pattern_of_constr -> B nat *)
+  (* exact hint *)
+  Check (_ : B nat).
+  (* map_eauto -> B_instance0 *)
+  (* NO Constr_matching.matches !!! *)
+  Check (_ : B _).
+
+  Goal exists T, B T.
+    eexists.
+    eauto with typeclass_instances.
+  Qed.
+
+  Local Instance: D ftest.
+  Local Hint Resolve flipD | 0 : typeclass_instances.
+  (* pattern: D (flip _) *)
+  Fail Timeout 1 Check (_ : D _). (* loops applying flipD *)  
+  
+End Instnopat.
+
+Module InstnopatApply.
+  Local Instance: I -> B nat.
+  (* pattern_of_constr -> B nat *)
+  (* apply hint  *)
+  Check (_ : B nat).
+  (* map_eauto -> B_instance0 *)
+  (* NO Constr_matching.matches !!! *)
+  Check (_ : B _).
+
+  Goal exists T, B T.
+    eexists.
+    eauto with typeclass_instances.
+  Qed.
+End InstnopatApply.
+  
+Module InstPat.
+  Hint Extern 3 (B nat) => split : typeclass_instances.
+  (* map_eauto -> Extern hint *)
+  (* Constr_matching.matches -> true *)
+  Check (_ : B nat).
+  (* map_eauto -> Extern hint *)
+  (* Constr_matching.matches -> false:
+     Because an inductive in the pattern does not match an evar in the goal *)
+  Check (_ : B _).
+
+  Goal exists T, B T.
+    eexists.
+    (* map_existential -> Extern hint *)
+    (* Constr_matching.matches -> false *)
+    Fail progress eauto with typeclass_instances.
+    (* map_eauto -> Extern hint *)
+    (* Constr_matching.matches -> false *)
+    Fail typeclasses eauto.
+  Abort.
+
+  Hint Extern 0 (D (flip _)) => apply flipD : typeclass_instances.
+  Module withftest.
+    Local Instance: D ftest.
+
+    Check (_ : D _).
+    (* D_instance_0 : D ftest *)
+    Check (_ : D (flip _)).
+    (* ... : D (flip ftest) *)
+  End withftest.
+  Module withoutftest.
+    Hint Extern 0 (D ftest) => split : typeclass_instances.
+    Check (_ : D _).
+    (* ? : D ?, _not_ looping *)
+    Check (_ : D (flip _)).
+    (* ? : D (flip ?), _not_ looping *)
+
+    Check (_ : D (flip ftest)).
+    (* flipD ftest {|  |} : D (flip ftest) *)
+  End withoutftest.
+End InstPat.
diff --git a/test-suite/success/bigQ.v b/test-suite/success/bigQ.v
new file mode 100644
index 00000000..7fd0cf66
--- /dev/null
+++ b/test-suite/success/bigQ.v
@@ -0,0 +1,66 @@
+Require Import BigQ.
+Import List.
+
+Definition pi_4_approx_low' := 
+(5066193963420194617885108698600649932059391557720145469382602092416947640628637390992675949693715109726079394291478795603894419483819297806310615866892414925850691415582239745615128821983865262221858109336884967754871321668348027076234335167119885298878199925731495390387858629042311908406056230882123787019283378509712244687397013657159455607193734144010901984756727174636853404278421831024545476850410085042498464474261035780891759930905778986584183710930670670301831474144997069400304290351567959717683444430666444319233768399342338059169002790777424962570605618705584660815518973602995097110557181643034682308210782171804373210646804613922337450953858508244032293753591878060539465788294318856859293281629951093130167801471787011911886414492513677892193100809508943832528344473873460853362957387889412799458784754514139679847887887544849825173792522272708046699681079289358082661375778523609867456540595586031625044964543428047238934233579184772793670436643502740076366994465457847106782560289782615794595755672643440040123002018908935362541166831619056664637901929131328502017686713274283777724453661234225382109584471950444925886358166551424008707439387934109226545596919797083495958300914344992836193126080289565652575543234385558967555959267746932292860747199382633363026440008828134867747920263181610216905129926037611247017868033961426567047355301676870662406173724238530061264149506666345040372864118731705584795947926329181826992456072045382170981478151356381437136818835196834068650217794381425547036331194595892801393225038235274901050364737353586927051766717037643833477566087835266968086513005761986678747515870298138062157791066648217784877968385924845017637219384732843791052551854695220023477365706464590594542001161575677402761543188277502092362285265847964496740584911576627239093631932307473445797386335961743298553548881544486940399236133577915988716682746485564575640818803540680574730591500432326858763829791848612343662539095316357052823005419355719381626599487868023399182174939253393897549026675976384326749445831606130546375395770778462506203752920470130305293966478109733954117063941901686840180727195741528561335809865193566993349413786715403053579411364371500063193205131503024022217701373077790337150298315820556080596579100618643147698304927957576213733526923182742441048553793831725592624850721293495085399785588171300815789795594858916409701139277050529011775828846362873246196866089783324522718656445008090114701320562608474099248873638488023114015981013142490827777895317580810590743940417298263300561876701828404744082864248409230009391001735746615476377303707782123483770118391136826609366946585715225248587168403619476143657107412319421501162805102723455593551478028055839072686207007765300258935153546418515706362733656094770289090398825190320430416955807878686642673124733998295439657633866090085982598765253268688814792672416195730086607425842181518560588819896560847103627615434844684536463752986969865794019299978956052589825441828842338163389851892617560591840546654410705167593310272272965900821031821380595084783691324416454359888103920904935692840264474003367023256964191100139001239923263691779167792867186165635514824889759796850863175082506408142175595463676408992027105356481220754473245821534527625758942093801142305560662681150069082553674495761075895588095760081401141419460482860852822686860785424514171214889677926763812031823537071721974799922995763666175738785000806081164280471363125324839717808977470218218571800106898347366938927189989988149888641129263448064762730769285877330997355234347773807099829665997515649429224335217107760728789764718885665291038706425454675746218345291274054088843647602239258308472486102933167465443294268551209015027897159307743987020521392788721231001835675584104894174434637260464035122611721657641428625505184886116917149318963070896162119215386541876236027342810162765609201440423207771441367926085768438143507025739041041240810056881304230519058117534418374553879198061289605354335880794397478047346975609179199801003098836622253165101961484972165230151495472006888128587168049198312469715081555662345452800468933420359802645393289853553618279788400476187713990872203669487294118461245455333004125835663010526985716431187034663870796866708678078952110615910196519835267441831874676895301527286826106517027821074816850326548617513767142627360001181210946100011774672126943957522004190414960909074050454565964857276407084991922274068961845339154089866785707764290964299529444616711194034827611771558783466230353209661849406004241580029437779784290315347968833708422223285859451369907260780956405036020581705441364379616715041818815829810906212826084485200785283123265202151252852134381195424724503189247411069117189489985791487434549080447866370484866697404176437230771558469231403088139693477706784802801265075586678597768511791952562627345622499328
+        # 100788726492580594349650258277496659410917619472657560321971265983799894639441017438166498752997098978003489632843381325240982516059309714013145358125224597827602157516585886911710102182473475545864474089191789296685473601331678556438310133356793199956062857423397512495293688453655805536015029176541424005214818033707522950635262669828538132795615008381824067071229426026518897202246241637377064076189277685257166926338187911595052586669184297526234794666364657344206795357967279911782849686515024121916258300642000317525374433525235296287037535618423661645124459323811792936193272341688261801253469089129439519903538495370298752436267926761998785090092411372633429302950606054074205533246665546979112178855223925266166034953000200646676762301817000435641690517142795144469005596172113586738287118865058604922865654348297975054956781513943444060257230946224520058527667925776273088622386666860662470481606622952298649177217986593047495967209669116410592230626047083795555559776477430548946990993890380787911273437967786556742804566652408275798339221179283430482118140020742719695900657696142739101628984271513292954605191778803974738871043737934546460016184719168074062912083778327025499841998124431899131874519812228674255796948879306477894924710085384116453080236862135706628989104070747737689294987000148388110561753028594988959655591699155508380909698460304884908709246116411180876105681720036833487450945730831039969246996849503525429840196651386469599438064049723005123629385485140945945416764414133189625489032807860400751723995946290581976152580477047961138617997133510128194027510895265424780627975864980749945631413855375897945293107842908479797077570371447220506451229526132919408351287454305932886749170523056147842439813407002950370505941417426433452282518739345666494683448699945734453214481915512562995906034771246088038719298959180199052759295868161570318718927430655393250250811804905393113074074574608255523847592006804881016594060188745212933427473833239777228852952217878690668413947367586040297784502192683200664398064682201012931468052982448022330449955215606614483165425935154496289535573901139223034819824408001205784146243892228030383941863746839845526558421740316887532141893650230936137269356278754487130882868595412163277284772124736531380334814212708066069618080153747333573454834500999083737284449542481264971030785043701582134343596645346132964567391370300568578875509971483039720438955919863275044932311289587494336123538202079503922025306586828117649623642521324286648529829664567232756108169459356549144779085080036654897525078792273443307070502103724611233768453196294899770515940520895908289018412144327894912660060761908970811602375085884115384049610753387776858733798341463052471017393165656926510611173543365663267563198760597092606598728110197523695339144204179424646442294307593146446562536865057987897899655645968129515654148044008249646703504419478535298270862753806142083172190778193001810574370442181909146645889199829207284871551220439225371051511970054965951914399901815408791418836185742573331879114400013259342896515702942707292473805188905427717363630137869116872433627556880809120353079342030725196065815470427569172350436988386579444534375353968759750750178342190349607711313840613843718547859929387259163285524671855725511880656411741012446023392964655239624520090988149679656514996202498334816938716757663800773997302639681907686195671083505910700098597156238624351157219093280177066146218516478636356056420098245995113668018177690728654922707281126889313941750547830163078886329630807850633273613622550216189245162735650139455042125252043274668279981753287687674520319519360593091620297805736177366738063651905396783336064579717230286821545930579779462534206093794040878198825916141099864730374109311705285661056855668930671948265232862757146615431791375559792290479316263924560826544387396762768331402198937951439504767950821089741987629257538953417586416459087855138539304027013800937360598578194413362672871055543854633921502486683911956250444582746421552178164852341035733290405311280719066037175324627429434912416361334254696649419037348733709488576582107382055914938194078813926926742828297826939120316120573453588052056773875836843924877773978390546387248009519202370375478981843515393806263037580338009594022254079586380520797699651840576286033587273591899639699077044271208886940540056794360292760863657703246410020854088849880453524038877935317875884698324859548991680533307680053872403383516589028793015681082435908524045497475001609824047204954932626536311826911363867426654549346914317405110707189532251727848751560224936842128628673253616256326013555922159336370177663785738170802777550686079119049748734352584409583136667752555307842739679930698964098088960000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)%bigQ
+.
+
+Definition pi_4_approx_high' := 
+(5066193963420194617885108698600649932059391557720145469382602092416947640628637390992675949693715109726079394291478795603894419483819297806310615866892414925850691415582239745615128821983865262221858109336884967754871321668348027076234335167119885298878199925731495390387858629042311908406056230882123787019283378509712244687397013657159455607193734144010901984756727174636853404278421831024545476850410085042498464474261035780891759930905778986584183710930670670301831474144997069400304290351567959717683444430666444319233768399342338059169002790777424962570605618705584660815518973602995097110557181643034682308210788409308322071457087096445676662503017187903223859814905546579050729173916234740628466315449085686468204847296426235788544874405450791749423436215032927889914519102361378633666267941326393265376660400091389373564825046526561381561278586121772300141564909333667988204680492088607706214346458601842899721615765319505314310192693665547163360402786722105590252780194994950097926184146718893770363322073641336811404180286358079915338791029818581497746089864894356686643882883410392601500048021013346713450539807687779704798018559373507951388092945938366448668853081682176581336156031434604604833692503597621519809826880683536141897075567053733515342478008373282599947520770191238802249392773327261328133194484586433840861730959791563023761306622956165536481335792721379318928171897265310054788931201902441066997927781894934061720760080768154565282051604447333036111267534150649674590201404453202347064545359869105856798745664471694795576801148562495225166002814304124970965817043547048503388910163287916513427409193998045119986267987892522931703487420953769290650229176116308194977201080691718825944370436642709192983358059711255925052564016519597530235976618244111239816418652282585432539731271068892992142956810775762851238126881225206289553948196520384709574383566733478326330112084307565420647201107231840508040019131253750047046446929758911912155202166566751947087545292626353331520202690130850009389387290465497377022080531269511355734944672010542204118978272180881335465227900174033380001851066811103401787656367819132934758616060307366679580043123632565656840669377840733018248707250548277181001911990237151790533341326223932843775840498222236867608395855700891719880219904948672458645420169533565809609056209006342663841718949396996175294237942265325043426430990062217643279654512512640557763489491751115437780462208361129433667449740743123546232162409802316714286708788831227582498585478334315076725145986771341647015244092760289407649044493584479944044779273447198382196766547779885914425854375158084417582279211000449529495605127376707776277159376010648950025135061284601443461110447113346277147728593420397807946636800365109579479211273476195727270004743568492888900356505584731622538401071221591141889158461271000051210318027818802379539544396973228585821742794928813630781709195703717312953337431290682263448669168179857644544116657440168099166467471736180072984407514757289757495435699300593165669101965987430482600019222913485092771346963058673132443387835726110205958057187517487684058179749952286341120230051432903482992282688283815697442898155194928723360957436110770317998431272108100149791425689283090777721270428030993332057319821685391144252815655146410678839177846108260765981523812232294638190350688210999605869296307711846463311346627138400477211801219366400312514793356564308532012682051019030257269068628100171220662165246389309014292764479226570049772046255291379151017129899157296574099437276707879597755725339406865738613810979022640265737120949077721294633786520294559343155148383011293584240192753971366644780434237846862975993387453786681995831719537733846579480995517357440575781962659282856696638992709756358478461648462532279323701121386551383509193782388241965285971965887701816406255233933761008649762854363984142178331798953040874526844255758512982810004271235810681505829473926495256537353108899526434200682024946218302499640511518360332022463196599199779172637638655415918976955930735312156870786600023896830267884391447789311101069654521354446521135407720085038662159974712373018912537116964809382149581004863115431780452188813210275393919111435118030412595133958954313836191108258769640843644195537185904547405641078708492098917460393911427237155683288565433183738513871595286090814836422982384810033331519971102974091067660369548406192526284519976668985518575216481570167748402860759832933071281814538397923687510782620605409323050353840034866296214149657376249634795555007199540807313397329050410326609108411299737760271566308288500400587417017113933243099961248847368789383209110747378488312550109911605079801570534271874115018095746872468910162721975463388518648962869080447866370484866697404176437230771558469231403088139693477706784802801265075586678597768511791952562627345622499328
+        # 100788726492580594349650258277496659410917619472657560321971265983799894639441017438166498752997098978003489632843381325240982516059309714013145358125224597827602157516585886911710102182473475545864474089191789296685473601331678556438310133356793199956062857423397512495293688453655805536015029176541424005214818033707522950635262669828538132795615008381824067071229426026518897202246241637377064076189277685257166926338187911595052586669184297526234794666364657344206795357967279911782849686515024121916258300642000317525374433525235296287037535618423661645124459323811792936193272341688261801253469089129439519903538495370298752436267926761998785090092411372633429302950606054074205533246665546979112178855223925266166034953000200646676762301817000435641690517142795144469005596172113586738287118865058604922865654348297975054956781513943444060257230946224520058527667925776273088622386666860662470481606622952298649177217986593047495967209669116410592230626047083795555559776477430548946990993890380787911273437967786556742804566652408275798339221179283430482118140020742719695900657696142739101628984271513292954605191778803974738871043737934546460016184719168074062912083778327025499841998124431899131874519812228674255796948879306477894924710085384116453080236862135706628989104070747737689294987000148388110561753028594988959655591699155508380909698460304884908709246116411180876105681720036833487450945730831039969246996849503525429840196651386469599438064049723005123629385485140945945416764414133189625489032807860400751723995946290581976152580477047961138617997133510128194027510895265424780627975864980749945631413855375897945293107842908479797077570371447220506451229526132919408351287454305932886749170523056147842439813407002950370505941417426433452282518739345666494683448699945734453214481915512562995906034771246088038719298959180199052759295868161570318718927430655393250250811804905393113074074574608255523847592006804881016594060188745212933427473833239777228852952217878690668413947367586040297784502192683200664398064682201012931468052982448022330449955215606614483165425935154496289535573901139223034819824408001205784146243892228030383941863746839845526558421740316887532141893650230936137269356278754487130882868595412163277284772124736531380334814212708066069618080153747333573454834500999083737284449542481264971030785043701582134343596645346132964567391370300568578875509971483039720438955919863275044932311289587494336123538202079503922025306586828117649623642521324286648529829664567232756108169459356549144779085080036654897525078792273443307070502103724611233768453196294899770515940520895908289018412144327894912660060761908970811602375085884115384049610753387776858733798341463052471017393165656926510611173543365663267563198760597092606598728110197523695339144204179424646442294307593146446562536865057987897899655645968129515654148044008249646703504419478535298270862753806142083172190778193001810574370442181909146645889199829207284871551220439225371051511970054965951914399901815408791418836185742573331879114400013259342896515702942707292473805188905427717363630137869116872433627556880809120353079342030725196065815470427569172350436988386579444534375353968759750750178342190349607711313840613843718547859929387259163285524671855725511880656411741012446023392964655239624520090988149679656514996202498334816938716757663800773997302639681907686195671083505910700098597156238624351157219093280177066146218516478636356056420098245995113668018177690728654922707281126889313941750547830163078886329630807850633273613622550216189245162735650139455042125252043274668279981753287687674520319519360593091620297805736177366738063651905396783336064579717230286821545930579779462534206093794040878198825916141099864730374109311705285661056855668930671948265232862757146615431791375559792290479316263924560826544387396762768331402198937951439504767950821089741987629257538953417586416459087855138539304027013800937360598578194413362672871055543854633921502486683911956250444582746421552178164852341035733290405311280719066037175324627429434912416361334254696649419037348733709488576582107382055914938194078813926926742828297826939120316120573453588052056773875836843924877773978390546387248009519202370375478981843515393806263037580338009594022254079586380520797699651840576286033587273591899639699077044271208886940540056794360292760863657703246410020854088849880453524038877935317875884698324859548991680533307680053872403383516589028793015681082435908524045497475001609824047204954932626536311826911363867426654549346914317405110707189532251727848751560224936842128628673253616256326013555922159336370177663785738170802777550686079119049748734352584409583136667752555307842739679930698964098088960000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)%bigQ
+.
+
+Fixpoint numden_Rcontfrac_tailrecB (accu: list bigZ) (n1 d1: bigZ) (n2 d2: bigZ) (fuel: nat) {struct fuel}:
+  (list bigZ * bigQ * bigQ) :=
+  let default := (rev_append accu nil, BigQ.div (BigQ.Qz n1) (BigQ.Qz d1), BigQ.div (BigQ.Qz n2) (BigQ.Qz d2)) in
+  match fuel with
+  | O => default
+  | S fuel' =>
+    let '(q1, r1) := BigZ.div_eucl n1 d1 in
+    let '(q2, r2) := BigZ.div_eucl n2 d2 in
+    match BigZ.eqb q1 q2 with
+    | false => default
+    | true =>
+      let r1_is_zero := BigZ.eqb r1 0 in
+      let r2_is_zero := BigZ.eqb r2 0 in
+      match Bool.eqb r1_is_zero r2_is_zero with
+      | false => default
+      | true =>
+        match r1_is_zero with
+          | true =>
+            match BigZ.eqb q1 1 with
+              | true => (rev_append accu nil, 1%bigQ, 1%bigQ)
+              | false => (rev_append ((q1 - 1)%bigZ :: accu) nil, 1%bigQ, 1%bigQ)
+            end
+          | false => numden_Rcontfrac_tailrecB (q1 :: accu) d1 r1 d2 r2 fuel'
+        end
+      end
+    end
+  end.
+
+Definition Bnum b :=
+  match b with
+  | BigQ.Qz t => t
+  | BigQ.Qq n d =>
+    if (d =? BigN.zero)%bigN then 0%bigZ else n
+  end.
+
+Definition Bden b :=
+  match b with
+  | BigQ.Qz _ => 1%bigN
+  | BigQ.Qq _ d => if (d =? BigN.zero)%bigN then 1%bigN else d 
+  end.
+
+Definition rat_Rcontfrac_tailrecB q1 q2 :=
+  numden_Rcontfrac_tailrecB nil (Bnum q1) (BigZ.Pos (Bden q1)) (Bnum q2) (BigZ.Pos (Bden q2)).
+
+Definition pi_4_contfrac :=
+  rat_Rcontfrac_tailrecB pi_4_approx_low' pi_4_approx_high' 3000.
+
+(* The following used to fail because of a non canonical representation of 0 in
+the bytecode interpreter. Bug reported privately by Tahina Ramananandro. *)
+Goal pi_4_contfrac = pi_4_contfrac.
+vm_compute.
+reflexivity.
+Qed.
diff --git a/test-suite/success/bteauto.v b/test-suite/success/bteauto.v
new file mode 100644
index 00000000..3178c6fc
--- /dev/null
+++ b/test-suite/success/bteauto.v
@@ -0,0 +1,170 @@
+Require Import Program.Tactics.
+Module Backtracking.
+  Class A := { foo : nat }.
+
+  Instance A_1 : A | 2 := { foo := 42 }.
+  Instance A_0 : A | 1 := { foo := 0 }.
+  Lemma aeq (a : A) : foo = foo.
+    reflexivity.
+  Qed.
+  
+  Arguments foo A : clear implicits.
+  Example find42 : exists n, n = 42.
+  Proof.
+    eexists.
+    eapply eq_trans.
+    evar (a : A). subst a.
+    refine (@aeq ?a).
+    Unshelve. all:cycle 1.
+    typeclasses eauto.
+    Fail reflexivity. 
+    Undo 2.
+    (* Without multiple successes it fails *)
+    Set Typeclasses Debug Verbosity 2.
+    Fail all:((once (typeclasses eauto with typeclass_instances))
+              + apply eq_refl).
+    (* Does backtrack if other goals fail *)
+    all:[> typeclasses eauto + reflexivity .. ].
+    Undo 1.
+    all:(typeclasses eauto + reflexivity). (* Note "+" is a focussing combinator *)
+    Show Proof.  
+  Qed.
+
+  Print find42.
+  
+  Hint Extern 0 (_ = _) => reflexivity : equality.
+  
+  Goal exists n, n = 42.
+    eexists.
+    eapply eq_trans.
+    evar (a : A). subst a.
+    refine (@aeq ?a).
+    Unshelve. all:cycle 1.
+    typeclasses eauto.
+    Fail reflexivity.
+    Undo 2.
+    
+    (* Does backtrack between individual goals *)
+    Set Typeclasses Debug.
+    all:(typeclasses eauto with typeclass_instances equality).
+  Qed.
+  
+  Unset Typeclasses Debug.
+
+  Module Leivant.
+    Axiom A : Type.
+    Existing Class A.
+    Axioms a b c d e: A.
+    
+    Ltac get_value H := eval cbv delta [H] in H.
+    
+    Goal True.
+      Fail refine (let H := _ : A in _); let v := get_value H in idtac v; fail.
+    Admitted.
+
+    Goal exists x:A, x=a.
+      unshelve evar (t : A). all:cycle 1.
+      refine (@ex_intro _ _ t _).
+      all:cycle 1.
+      all:(typeclasses eauto + reflexivity).
+    Qed.      
+  End Leivant.
+End Backtracking.
+
+
+Hint Resolve 100 eq_sym eq_trans : core.
+Hint Cut [(_)* eq_sym eq_sym] : core.
+Hint Cut [_* eq_trans eq_trans] : core.
+Hint Cut [_* eq_trans eq_sym eq_trans] : core.
+
+
+Goal forall x y z : nat, x = y -> z = y -> x = z.
+Proof.
+  intros.
+  typeclasses eauto with core.
+Qed.
+
+Module Hierarchies.
+  Class A := mkA { data : nat }.
+  Class B := mkB { aofb :> A }.
+
+  Existing Instance mkB.
+
+  Definition makeB (a : A) : B := _.
+  Definition makeA (a : B) : A := _.
+
+  Fail Timeout 1 Definition makeA' : A := _.
+
+  Hint Cut [_* mkB aofb] : typeclass_instances.
+  Fail Definition makeA' : A := _.
+  Fail Definition makeB' : B := _.
+End Hierarchies.
+
+(** Hint modes *)
+
+Class Equality (A : Type) := { eqp : A -> A -> Prop }.
+
+Check (eqp 0%nat 0).
+
+Instance nat_equality : Equality nat := { eqp := eq }.
+
+Instance default_equality A : Equality A | 1000 :=
+  { eqp := eq }.
+
+Check (eqp 0%nat 0).
+
+(* Defaulting *)
+Check (fun x y => eqp x y).
+(* No more defaulting, reduce "trigger-happiness" *)
+Definition ambiguous x y := eqp x y.
+
+Hint Mode Equality ! : typeclass_instances.
+Fail Definition ambiguous' x y := eqp x y.
+Definition nonambiguous (x y : nat) := eqp x y.
+
+(** Typical looping instances with defaulting: *)
+Definition flip {A B C} (f : A -> B -> C) := fun x y => f y x.
+
+Class SomeProp {A : Type} (f : A -> A -> A) :=
+  { prf : forall x y, f x y = f x y }.
+
+Instance propflip (A : Type) (f : A -> A -> A) :
+  SomeProp f -> SomeProp (flip f).
+Proof.
+  intros []. constructor. reflexivity.
+Qed.
+
+Fail Timeout 1 Check prf.
+
+Hint Mode SomeProp + + : typeclass_instances.
+Check prf.
+Check (fun H : SomeProp plus => _ : SomeProp (flip plus)).
+
+(** Iterative deepening / breadth-first search *)
+
+Module IterativeDeepening.
+
+  Class A.
+  Class B.
+  Class C.
+
+  Instance: B -> A | 0.
+  Instance: C -> A | 0.
+  Instance: C -> B -> A | 0.
+  Instance: A -> A | 0.
+  
+  Goal C -> A.
+    intros.
+    Fail Timeout 1 typeclasses eauto.
+    Set Typeclasses Iterative Deepening.
+    Fail typeclasses eauto 1.
+    typeclasses eauto 2.
+    Undo.
+    Unset Typeclasses Iterative Deepening.
+    Fail Timeout 1 typeclasses eauto.
+    Set Typeclasses Iterative Deepening.
+    Typeclasses eauto := debug 3.
+    typeclasses eauto.
+  Qed.
+
+End IterativeDeepening.
diff --git a/test-suite/success/cc.v b/test-suite/success/cc.v
index a70d9196..bbfe5ec4 100644
--- a/test-suite/success/cc.v
+++ b/test-suite/success/cc.v
@@ -129,5 +129,25 @@ Qed.
 
 End bug_2447.
 
+(* congruence was supposed to do discriminate but it was bugged for
+   types with indices *)
 
+Inductive I : nat -> Type := C : I 0 | D : I 0.
+Goal ~C=D.
+congruence.
+Qed.
+
+(* Example by Jonathan Leivant, congruence up to universes *)
+Section JLeivant.
+  Variables S1 S2 : Set.
+
+  Definition T1 : Type := S1.
+  Definition T2 : Type := S2.
 
+  Goal T1 = T1.
+    congruence.
+    Undo.
+    unfold T1.
+    congruence.
+  Qed.
+End JLeivant.
diff --git a/test-suite/success/clear.v b/test-suite/success/clear.v
index 976bec73..e25510cf 100644
--- a/test-suite/success/clear.v
+++ b/test-suite/success/clear.v
@@ -13,3 +13,21 @@ Goal forall y z, (forall x:nat, x=y -> True) -> y=z -> True.
   reflexivity.
 Qed.
 
+Class A.
+
+Section Foo.
+
+  Variable a : A.
+
+  Goal A.
+    solve [typeclasses eauto].
+    Undo 1.
+    clear a.
+    try typeclasses eauto.
+    assert(a:=Build_A).
+    solve [ typeclasses eauto ].
+    Undo 2.
+    assert(b:=Build_A).
+    solve [ typeclasses eauto ].
+  Qed.
+End Foo.
\ No newline at end of file
diff --git a/test-suite/success/coindprim.v b/test-suite/success/coindprim.v
index 4e0b7bf5..5b9265b6 100644
--- a/test-suite/success/coindprim.v
+++ b/test-suite/success/coindprim.v
@@ -1,36 +1,75 @@
+Require Import Program.
+
 Set Primitive Projections.
 
-CoInductive stream A := { hd : A; tl : stream A }.
+CoInductive Stream (A : Type) := mkStream { hd : A; tl : Stream A}.
 
-CoFixpoint ticks : stream unit :=
-  {| hd := tt; tl := ticks |}.
+Arguments mkStream [A] hd tl.
+Arguments hd [A] s.
+Arguments tl [A] s.
 
-Arguments hd [ A ] s.
-Arguments tl [ A ] s.
+Definition eta {A} (s : Stream A) := {| hd := s.(hd); tl := s.(tl) |}.
 
-CoInductive bisim {A} : stream A -> stream A -> Prop :=
-  | bisims s s' : hd s = hd s' -> bisim (tl s) (tl s') -> bisim s s'.
+CoFixpoint ones := {| hd := 1; tl := ones |}.
+CoFixpoint ticks := {| hd := tt; tl := ticks |}.
 
-Lemma bisim_refl {A} (s : stream A) : bisim s s.
-Proof.
-  revert s.
-  cofix aux. intros. constructor. reflexivity. apply aux.
-Defined.
+CoInductive stream_equiv {A} {s : Stream A} {s' : Stream A} : Prop :=
+  mkStreamEq { hdeq : s.(hd) = s'.(hd); tleq : stream_equiv _ s.(tl) s'.(tl) }.
+Arguments stream_equiv {A} s s'.
 
-Lemma constr : forall (A : Type) (s : stream A),
-    bisim s (Build_stream _ s.(hd) s.(tl)).
-Proof.
-  intros. constructor. reflexivity. simpl. apply bisim_refl.
-Defined.
+Program CoFixpoint ones_eq : stream_equiv ones ones.(tl) :=
+  {| hdeq := eq_refl; tleq := ones_eq |}.
+
+CoFixpoint stream_equiv_refl {A} (s : Stream A) : stream_equiv s s :=
+  {| hdeq := eq_refl; tleq := stream_equiv_refl (tl s) |}.
+
+CoFixpoint stream_equiv_sym {A} (s s' : Stream A) (H : stream_equiv s s') : stream_equiv s' s :=
+  {| hdeq := eq_sym H.(hdeq); tleq := stream_equiv_sym _ _ H.(tleq) |}.
+
+CoFixpoint stream_equiv_trans {A} {s s' s'' : Stream A}
+           (H : stream_equiv s s') (H' : stream_equiv s' s'') : stream_equiv s s'' :=
+  {| hdeq := eq_trans H.(hdeq) H'.(hdeq);
+     tleq := stream_equiv_trans H.(tleq) H'.(tleq) |}.
 
-Lemma constr' : forall (A : Type) (s : stream A),
-  s = Build_stream _ s.(hd) s.(tl).
+Program Definition eta_eq {A} (s : Stream A) : stream_equiv s (eta s):=
+  {| hdeq := eq_refl; tleq := stream_equiv_refl (tl (eta s))|}.
+
+Section Parks.
+  Variable A : Type.
+
+  Variable R : Stream A -> Stream A -> Prop.
+  Hypothesis bisim1 : forall s1 s2:Stream A,
+      R s1 s2 -> hd s1 = hd s2.
+  Hypothesis bisim2 : forall s1 s2:Stream A,
+      R s1 s2 -> R (tl s1) (tl s2).
+  CoFixpoint park_ppl :
+    forall s1 s2:Stream A, R s1 s2 -> stream_equiv s1 s2 :=
+    fun s1 s2 (p : R s1 s2) =>
+      mkStreamEq _ _ _ (bisim1 s1 s2 p)
+      (park_ppl (tl s1)
+                (tl s2)
+                (bisim2 s1 s2 p)).
+End Parks.
+
+Program CoFixpoint iterate {A} (f : A -> A) (x : A) : Stream A :=
+  {| hd := x; tl := iterate f (f x) |}.
+
+Program CoFixpoint map {A B} (f : A -> B) (s : Stream A) : Stream B :=
+  {| hd := f s.(hd); tl := map f s.(tl) |}.
+
+Theorem map_iterate A (f : A -> A) (x : A) : stream_equiv (iterate f (f x))
+                                                         (map f (iterate f x)).
 Proof.
-  intros. 
-  Fail destruct s. 
-Abort.
+apply park_ppl with
+(R:= fun s1 s2 => exists x : A, s1 = iterate f (f x) /\
+                        s2 = map f (iterate f x)).
+now intros s1 s2 (x0,(->,->)).
+intros s1 s2 (x0,(->,->)).
+now exists (f x0).
+now exists x. 
+Qed.
 
-Eval compute in constr _ ticks.
+Fail Check (fun A (s : Stream A) => eq_refl : s = eta s).
 
 Notation convertible x y := (eq_refl x : x = y).
 
diff --git a/test-suite/success/contradiction.v b/test-suite/success/contradiction.v
new file mode 100644
index 00000000..92a7c6cc
--- /dev/null
+++ b/test-suite/success/contradiction.v
@@ -0,0 +1,32 @@
+(* Some tests for contradiction *)
+
+Lemma L1 : forall A B : Prop, A -> ~A -> B.
+Proof.
+intros; contradiction.
+Qed.
+
+Lemma L2 : forall A B : Prop, ~A -> A -> B.
+Proof.
+intros; contradiction.
+Qed.
+
+Lemma L3 : forall A : Prop, ~True -> A.
+Proof.
+intros; contradiction.
+Qed.
+
+Lemma L4 : forall A : Prop, forall x : nat, ~x=x -> A.
+Proof.
+intros; contradiction.
+Qed.
+
+Lemma L5 : forall A : Prop, forall x y : nat, ~x=y -> x=y -> A.
+Proof.
+intros; contradiction.
+Qed.
+
+Lemma L6 : forall A : Prop, forall x y : nat, x=y -> ~x=y -> A.
+Proof.
+intros; contradiction.
+Qed.
+
diff --git a/test-suite/success/decl_mode2.v b/test-suite/success/decl_mode2.v
new file mode 100644
index 00000000..46174e48
--- /dev/null
+++ b/test-suite/success/decl_mode2.v
@@ -0,0 +1,249 @@
+Theorem this_is_trivial: True.
+proof.
+  thus thesis.
+end proof.
+Qed.
+
+Theorem T: (True /\ True) /\ True.
+  split. split.
+proof. (* first subgoal *)
+  thus thesis.
+end proof.
+trivial. (* second subgoal *)
+proof. (* third subgoal *)
+  thus thesis.
+end proof.
+Abort.
+
+Theorem this_is_not_so_trivial: False.
+proof.
+end proof. (* here a warning is issued *)
+Fail Qed. (* fails: the proof in incomplete *)
+Admitted. (* Oops! *)
+
+Theorem T: True.
+proof.
+escape.
+auto.
+return.
+Abort.
+
+Theorem T: let a:=false in let b:= true in ( if a then True else False -> if b then True else False).
+intros a b.
+proof.
+assume H:(if a then True else False).
+reconsider H as False.
+reconsider thesis as True.
+Abort.
+
+Theorem T: forall x, x=2 -> 2+x=4.
+proof.
+let x be such that H:(x=2).
+have H':(2+x=2+2) by H.
+Abort.
+
+Theorem T: forall x, x=2 -> 2+x=4.
+proof.
+let x be such that H:(x=2).
+then (2+x=2+2).
+Abort.
+
+Theorem T: forall x, x=2 -> x + x = x * x.
+proof.
+let x be such that H:(x=2).
+have (4 = 4).
+        ~= (2 * 2).
+        ~= (x * x) by H.
+        =~ (2 + 2).
+        =~ H':(x + x) by H.
+Abort.
+
+Theorem T: forall x, x + x = x * x -> x = 0 \/ x = 2.
+proof.
+let x be such that H:(x + x = x * x).
+claim H':((x - 2) * x = 0).
+thus thesis. 
+end claim.
+Abort.
+
+Theorem T: forall (A B:Prop), A -> B -> A /\ B.
+intros A B HA HB.
+proof.
+hence B.
+Abort.
+
+Theorem T: forall (A B C:Prop), A -> B -> C -> A /\ B /\ C.
+intros A B C HA HB HC.
+proof.
+thus B by HB.
+Abort.
+
+Theorem T: forall (A B C:Prop), A -> B -> C -> A /\ B.
+intros A B C HA HB HC.
+proof.
+Fail hence C. (* fails *)
+Abort.
+
+Theorem T: forall (A B:Prop), B -> A \/ B.
+intros A B HB.
+proof.
+hence B.
+Abort.
+
+Theorem T: forall (A B C D:Prop), C -> D -> (A /\ B) \/ (C /\ D).
+intros A B C D HC HD.
+proof.
+thus C by HC.
+Abort.
+
+Theorem T: forall (P:nat -> Prop), P 2 -> exists x,P x.
+intros P HP.
+proof.
+take 2.
+Abort.
+
+Theorem T: forall (P:nat -> Prop), P 2 -> exists x,P x.
+intros P HP.
+proof.
+hence (P 2).
+Abort.
+
+Theorem T: forall (P:nat -> Prop) (R:nat -> nat -> Prop), P 2 -> R 0 2 -> exists x, exists y, P y /\ R x y.
+intros P R HP HR.
+proof.
+thus (P 2) by HP.
+Abort.
+
+Theorem T: forall (A B:Prop) (P:nat -> Prop), (forall x, P x -> B) -> A -> A /\ B.
+intros A B P HP HA.
+proof.
+suffices to have x such that HP':(P x) to show B by HP,HP'.
+Abort.
+
+Theorem T: forall (A:Prop) (P:nat -> Prop), P 2 -> A -> A /\ (forall x, x = 2 -> P x).
+intros A P HP HA.
+proof.
+(* BUG: the next line fails when it should succeed.
+Waiting for someone to investigate the bug.
+focus on (forall x, x = 2 -> P x).
+let x be such that (x = 2).
+hence thesis by HP.
+end focus.
+*)
+Abort.
+
+Theorem T: forall x, x = 0 -> x + x = x * x.
+proof.
+let x be such that H:(x = 0).
+define sqr x as (x * x).
+reconsider thesis as (x + x = sqr x).
+Abort.
+
+Theorem T: forall (P:nat -> Prop), forall x, P x -> P x.
+proof.
+let P:(nat -> Prop).
+let x:nat.
+assume HP:(P x).
+Abort.
+
+Theorem T: forall (P:nat -> Prop), forall x, P x -> P x.
+proof.
+let P:(nat -> Prop).
+Fail let x. (* fails because x's type is not clear *) 
+let x be such that HP:(P x). (* here x's type is inferred from (P x) *)
+Abort.
+
+Theorem T: forall (P:nat -> Prop), forall x, P x -> P x -> P x.
+proof.
+let P:(nat -> Prop).
+let x:nat.
+assume (P x). (* temporary name created *)
+Abort.
+
+Theorem T: forall (P:nat -> Prop), forall x, P x -> P x.
+proof.
+let P:(nat -> Prop).
+let x be such that (P x). (* temporary name created *)
+Abort.
+
+Theorem T: forall (P:nat -> Prop) (A:Prop), (exists x, (P x /\ A)) -> A.
+proof.
+let P:(nat -> Prop),A:Prop be such that H:(exists x, P x /\ A).
+consider x such that HP:(P x) and HA:A from H.
+Abort.
+
+(* Here is an example with pairs: *)
+
+Theorem T: forall p:(nat * nat)%type, (fst p >= snd p) \/ (fst p < snd p).
+proof.
+let p:(nat * nat)%type.
+consider x:nat,y:nat from p.
+reconsider thesis as (x >= y \/ x < y). 
+Abort.
+
+Theorem T: forall P:(nat -> Prop), (forall n, P n -> P (n - 1)) -> 
+(exists m, P m) -> P 0.
+proof.
+let P:(nat -> Prop) be such that HP:(forall n, P n -> P (n - 1)).
+given m such that Hm:(P m).  
+Abort.
+
+Theorem T: forall (A B C:Prop), (A -> C) -> (B -> C) -> (A \/ B) -> C.
+proof.
+let A:Prop,B:Prop,C:Prop be such that HAC:(A -> C) and HBC:(B -> C).
+assume HAB:(A \/ B).
+per cases on HAB.
+suppose A.
+  hence thesis by HAC.
+suppose HB:B.
+  thus thesis by HB,HBC.
+end cases.
+Abort.
+
+Section Coq.
+
+Hypothesis EM : forall P:Prop, P \/ ~ P.
+
+Theorem T: forall (A C:Prop), (A -> C) -> (~A -> C) -> C.
+proof.
+let A:Prop,C:Prop be such that HAC:(A -> C) and HNAC:(~A -> C).
+per cases of (A \/ ~A) by EM.
+suppose (~A).
+  hence thesis by HNAC.
+suppose A.
+  hence thesis by HAC.
+end cases.
+Abort.
+
+Theorem T: forall (A C:Prop), (A -> C) -> (~A -> C) -> C.
+proof.
+let A:Prop,C:Prop be such that HAC:(A -> C) and HNAC:(~A -> C).
+per cases on (EM A).
+suppose (~A).
+Abort.
+End Coq.
+
+Theorem T: forall (A B:Prop) (x:bool), (if x then A else B) -> A \/ B.
+proof.
+let A:Prop,B:Prop,x:bool.
+per cases on x.
+suppose it is true.
+  assume A.
+  hence A.
+suppose it is false.
+  assume B.
+  hence B.
+end cases.
+Abort.
+
+Theorem T: forall (n:nat), n + 0 = n.
+proof.
+let n:nat.
+per induction on n.
+suppose it is 0.
+  thus (0 + 0 = 0).
+suppose it is (S m) and H:thesis for m.
+  then (S (m + 0) = S m).
+  thus =~ (S m + 0).
+end induction.
+Abort.
\ No newline at end of file
diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v
index 9f091e39..90a60daa 100644
--- a/test-suite/success/destruct.v
+++ b/test-suite/success/destruct.v
@@ -96,21 +96,21 @@ Abort.
 (* Check that subterm selection does not solve existing evars *)
 
 Goal exists x, S x = S 0.
-eexists.
+eexists ?[x].
 Show x.  (* Incidentally test Show on a named goal *)
 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.
+eexists ?[x].
 destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *)
 change (0 = S ?x).
 [x]: exact 0. (* Incidentally test applying a tactic to a goal on the shelve *)
 Abort.
 
 Goal exists n p:nat, (S n,S n) = (S p,S p) /\ p = n.
-do 2 eexists.
+eexists ?[n]; eexists ?[p].
 destruct (_, S _). (* Was unifying at some time in trunk, now takes the first occurrence *)
 change ((n, n0) = (S ?p, S ?p) /\ ?p = ?n).
 Abort.
@@ -426,7 +426,7 @@ destruct b eqn:H.
 (* Check natural instantiation behavior when the goal has already an evar *)
 
 Goal exists x, S x = x.
-eexists.
+eexists ?[x].
 destruct (S _).
 change (0 = ?x).
 Abort.
diff --git a/test-suite/success/eauto.v b/test-suite/success/eauto.v
index 773dd321..160f2d9d 100644
--- a/test-suite/success/eauto.v
+++ b/test-suite/success/eauto.v
@@ -5,6 +5,184 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
+
+Class A (A : Type).
+  Instance an: A nat.
+
+Class B (A : Type) (a : A).
+Instance bn0: B nat 0.
+Instance bn1: B nat 1.
+
+Goal A nat.
+Proof.
+  typeclasses eauto.
+Qed.
+
+Goal B nat 2.
+Proof.
+  Fail typeclasses eauto.
+Abort.
+
+Goal exists T : Type, A T.
+Proof.
+  eexists. typeclasses eauto.
+Defined.
+
+Hint Extern 0 (_ /\ _) => constructor : typeclass_instances.
+
+Existing Class and.
+
+Goal exists (T : Type) (t : T), A T /\ B T t.
+Proof.
+  eexists. eexists. typeclasses eauto.
+Defined.
+
+Instance ab: A bool. (* Backtrack on A instance *)
+Goal exists (T : Type) (t : T), A T /\ B T t.
+Proof.
+  eexists. eexists. typeclasses eauto.
+Defined.
+
+Class C {T} `(a : A T) (t : T). 
+Require Import Classes.Init.
+Hint Extern 0 { x : ?A & _ } =>
+  unshelve class_apply @existT : typeclass_instances.
+Existing Class sigT.
+Set Typeclasses Debug.
+Instance can: C an 0.
+(* Backtrack on instance implementation *)
+Goal exists (T : Type) (t : T), { x : A T & C x t }.
+Proof.
+  eexists. eexists. typeclasses eauto.
+Defined.
+
+Class D T `(a: A T).
+  Instance: D _ an.
+Goal exists (T : Type), { x : A T & D T x }.
+Proof.
+  eexists. typeclasses eauto.
+Defined.
+  
+
+(* Example from Nicolas Magaud on coq-club - Jul 2000 *)
+
+Definition Nat : Set := nat.
+Parameter S' : Nat -> Nat.
+Parameter plus' : Nat -> Nat -> Nat.
+
+Lemma simpl_plus_l_rr1 :
+ (forall n0 : Nat,
+  (forall m p : Nat, plus' n0 m = plus' n0 p -> m = p) ->
+  forall m p : Nat, S' (plus' n0 m) = S' (plus' n0 p) -> m = p) ->
+ forall n : Nat,
+ (forall m p : Nat, plus' n m = plus' n p -> m = p) ->
+ forall m p : Nat, S' (plus' n m) = S' (plus' n p) -> m = p.
+  intros.
+  apply H0. apply f_equal_nat.
+  Time info_eauto.
+  Undo.
+  Set Typeclasses Debug.
+  Set Typeclasses Iterative Deepening.
+  Time typeclasses eauto 6 with nocore. Show Proof.
+  Undo.
+  Time eauto. (* does EApply H *)
+Qed.
+
+(* Example from Nicolas Tabareau on coq-club - Feb 2016. 
+  Full backtracking on dependent subgoals.
+ *)
+Require Import Coq.Classes.Init.
+
+Module NTabareau.
+
+Set Typeclasses Dependency Order.
+Unset Typeclasses Iterative Deepening.
+Notation "x .1" := (projT1 x) (at level 3).
+Notation "x .2" := (projT2 x) (at level 3).
+
+Parameter myType: Type. 
+
+Class Foo (a:myType) := {}.
+
+Class Bar (a:myType) := {}.
+
+Class Qux (a:myType) := {}.
+
+Parameter fooTobar : forall a (H : Foo a), {b: myType & Bar b}.
+
+Parameter barToqux : forall a (H : Bar a), {b: myType & Qux b}.
+
+Hint Extern 5 (Bar ?D.1) =>
+    destruct D; simpl : typeclass_instances.
+
+Hint Extern 5 (Qux ?D.1) =>
+    destruct D; simpl : typeclass_instances.
+
+Hint Extern 1 myType =>
+  unshelve refine (fooTobar _ _).1 : typeclass_instances.
+
+Hint Extern 1 myType => unshelve refine (barToqux _ _).1 : typeclass_instances.
+
+Hint Extern 0 { x : _ & _ } => simple refine (existT _ _ _) : typeclass_instances.
+
+Unset Typeclasses Debug.
+Definition trivial a (H : Foo a) : {b : myType & Qux b}. 
+Proof.
+  Time typeclasses eauto 10 with typeclass_instances.
+  Undo. Set Typeclasses Iterative Deepening.
+  Time typeclasses eauto with typeclass_instances.
+Defined.
+
+End NTabareau.
+
+Module NTabareauClasses.
+
+Set Typeclasses Dependency Order.
+Unset Typeclasses Iterative Deepening.
+Notation "x .1" := (projT1 x) (at level 3).
+Notation "x .2" := (projT2 x) (at level 3).
+
+Parameter myType: Type. 
+Existing Class myType.
+
+Class Foo (a:myType) := {}.
+
+Class Bar (a:myType) := {}.
+
+Class Qux (a:myType) := {}.
+
+Parameter fooTobar : forall a (H : Foo a), {b: myType & Bar b}.
+
+Parameter barToqux : forall a (H : Bar a), {b: myType & Qux b}.
+
+Hint Extern 5 (Bar ?D.1) =>
+    destruct D; simpl : typeclass_instances.
+
+Hint Extern 5 (Qux ?D.1) =>
+    destruct D; simpl : typeclass_instances.
+
+Hint Extern 1 myType =>
+  unshelve notypeclasses refine (fooTobar _ _).1 : typeclass_instances.
+
+Hint Extern 1 myType =>
+  unshelve notypeclasses refine (barToqux _ _).1 : typeclass_instances.
+
+Hint Extern 0 { x : _ & _ } =>
+  unshelve notypeclasses refine (existT _ _ _) : typeclass_instances.
+
+Unset Typeclasses Debug.
+
+Definition trivial a (H : Foo a) : {b : myType & Qux b}. 
+Proof.
+  Time typeclasses eauto 10 with typeclass_instances.
+  Undo. Set Typeclasses Iterative Deepening.
+  (* Much faster in iteratove deepening mode *)
+  Time typeclasses eauto with typeclass_instances.
+Defined.
+
+End NTabareauClasses.
+
+
 Require Import List.
 
 Parameter in_list : list (nat * nat) -> nat -> Prop.
@@ -38,23 +216,6 @@ Hint Resolve lem1 lem2 lem3 lem4: essai.
 Goal
 forall (l : list (nat * nat)) (n p q : nat),
 not_in_list ((p, q) :: l) n -> not_in_list l n.
-intros.
- eauto with essai.
-Qed.
-
-(* Example from Nicolas Magaud on coq-club - Jul 2000 *)
-
-Definition Nat : Set := nat.
-Parameter S' : Nat -> Nat.
-Parameter plus' : Nat -> Nat -> Nat.
-
-Lemma simpl_plus_l_rr1 :
- (forall n0 : Nat,
-  (forall m p : Nat, plus' n0 m = plus' n0 p -> m = p) ->
-  forall m p : Nat, S' (plus' n0 m) = S' (plus' n0 p) -> m = p) ->
- forall n : Nat,
- (forall m p : Nat, plus' n m = plus' n p -> m = p) ->
- forall m p : Nat, S' (plus' n m) = S' (plus' n p) -> m = p.
-intros.
- eauto. (* does EApply H *)
+  intros.
+  eauto with essai.
 Qed.
diff --git a/test-suite/success/eqdecide.v b/test-suite/success/eqdecide.v
index 1f6af0dc..724e2998 100644
--- a/test-suite/success/eqdecide.v
+++ b/test-suite/success/eqdecide.v
@@ -14,6 +14,18 @@ Lemma lem1 : forall x y : T, {x = y} + {x <> y}.
  decide equality.
 Qed.
 
+Lemma lem1' : forall x y : T, x = y \/ x <> y.
+ decide equality.
+Qed.
+
+Lemma lem1'' : forall x y : T, {x <> y} + {x = y}.
+ decide equality.
+Qed.
+
+Lemma lem1''' : forall x y : T, x <> y \/ x = y.
+ decide equality.
+Qed.
+
 Lemma lem2 : forall x y : T, {x = y} + {x <> y}.
 intros x y.
  decide equality.
diff --git a/test-suite/success/goal_selector.v b/test-suite/success/goal_selector.v
new file mode 100644
index 00000000..86814051
--- /dev/null
+++ b/test-suite/success/goal_selector.v
@@ -0,0 +1,55 @@
+Inductive two : bool -> Prop :=
+| Zero : two false
+| One : two true.
+
+Ltac dup :=
+  let H := fresh in assert (forall (P : Prop), P -> P -> P) as H by (intros; trivial);
+  apply H; clear H.
+
+Lemma transform : two false <-> two true.
+Proof. split; intros _; constructor. Qed.
+
+Goal two false /\ two true /\ two false /\ two true /\ two true /\ two true.
+Proof.
+  do 2 dup.
+  - repeat split.
+    2, 4-99, 100-3:idtac.
+    2-5:exact One.
+    par:exact Zero.
+  - repeat split.
+    3-6:swap 1 4.
+    1-5:swap 1 5.
+    0-4:exact One.
+    all:exact Zero.
+  - repeat split.
+    1, 3:exact Zero.
+    1, 2, 3, 4: exact One.
+  - repeat split.
+    all:apply transform.
+    2, 4, 6:apply transform.
+    all:apply transform.
+    1-5:apply transform.
+    1-6:exact One.
+Qed.
+
+Goal True -> True.
+Proof.
+  intros y; only 1-2 : repeat idtac.
+  1-1:match goal with y : _ |- _ => let x := y in idtac x end.
+  Fail 1-1:let x := y in idtac x.
+  1:let x := y in idtac x.
+  exact I.
+Qed.
+
+Goal True /\ (True /\ True).
+Proof.
+  dup.
+  - split; only 2: (split; exact I).
+    exact I.
+  - split; only 2: split; exact I.
+Qed.
+
+Goal True -> exists (x : Prop), x.
+Proof.
+  intro H; eexists ?[x]; only [x]: exact True. 1: assumption.
+Qed.
diff --git a/test-suite/success/induct.v b/test-suite/success/induct.v
index b8c6bf3f..1ed731f5 100644
--- a/test-suite/success/induct.v
+++ b/test-suite/success/induct.v
@@ -151,3 +151,46 @@ intros x H1 H.
 induction H.
 change (0 = z -> True) in IHrepr''.
 Abort.
+
+(* Test double induction *)
+
+(* This was failing in 8.5 and before because of a bug in the order of
+   hypotheses *)
+
+Inductive I2 : Type :=
+  C2 : forall x:nat, x=x -> I2.
+Goal forall a b:I2, a = b.
+double induction a b.
+Abort.
+
+(* This was leaving useless hypotheses in 8.5 and before because of
+   the same bug. This is a change of compatibility. *)
+
+Inductive I3 : Prop :=
+  C3 : forall x:nat, x=x -> I3.
+Goal forall a b:I3, a = b.
+double induction a b.
+Fail clear H. (* H should have been erased *)
+Abort.
+
+(* This one had quantification in reverse order in 8.5 and before *)
+(* This is a change of compatibility. *)
+
+Goal forall m n, le m n -> le n m -> n=m.
+intros m n. double induction 1 2.
+3:destruct 1. (* Should be "S m0 <= m0" *)
+Abort.
+
+(* Idem *)
+
+Goal forall m n p q, le m n -> le p q -> n+p=m+q.
+intros *. double induction 1 2.
+3:clear H2. (* H2 should have been erased *)
+Abort.
+
+(* This is unchanged *)
+
+Goal forall m n:nat, n=m.
+double induction m n.
+Abort.
+
diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v
index 11156aa0..ee69df97 100644
--- a/test-suite/success/intros.v
+++ b/test-suite/success/intros.v
@@ -84,3 +84,47 @@ Qed.
 Goal forall x : nat, True.
 intros y%(fun x => x).
 Abort.
+
+(* Fixing a bug in the order of side conditions of a "->" step *)
+
+Goal (True -> 1=0) -> 1=1.
+intros ->.
+- reflexivity.
+- exact I.
+Qed.
+
+Goal forall x, (True -> x=0) -> 0=x.
+intros x ->.
+- reflexivity.
+- exact I.
+Qed.
+
+(* Fixing a bug when destructing a type with let-ins in the constructor *)
+
+Inductive I := C : let x:=1 in x=1 -> I.
+Goal I -> True.
+intros [x H]. (* Was failing in 8.5 *)
+Abort.
+
+(* Ensuring that the (pat1,...,patn) intropatterns has the expected size, up
+   to skipping let-ins *)
+
+Goal I -> 1=1.
+intros (H).  (* This skips x *)
+exact H.
+Qed.
+
+Goal I -> 1=1.
+Fail intros (x,H,H').
+Fail intros [|].
+intros (x,H).
+exact H.
+Qed.
+
+Goal Acc le 0 -> True.
+Fail induction 1 as (n,H). (* Induction hypothesis is missing *)
+induction 1 as (n,H,IH).
+exact Logic.I.
+Qed.
+
+
diff --git a/test-suite/success/keyedrewrite.v b/test-suite/success/keyedrewrite.v
index 5b0502cf..b88c142b 100644
--- a/test-suite/success/keyedrewrite.v
+++ b/test-suite/success/keyedrewrite.v
@@ -58,4 +58,5 @@ Qed.
 
    Lemma test b : b && true = b.
     Fail rewrite andb_true_l.
-   Admitted.
\ No newline at end of file
+   Admitted.
+   
\ No newline at end of file
diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v
index 6c4d4ae9..ce909905 100644
--- a/test-suite/success/ltac.v
+++ b/test-suite/success/ltac.v
@@ -15,7 +15,7 @@ Ltac F x := idtac; G x
  with G y := idtac; F y.
 
 (* Check that Match Context keeps a closure *)
-Ltac U := let a := constr:I in
+Ltac U := let a := constr:(I) in
           match goal with
           |  |- _ => apply a
           end.
@@ -75,7 +75,7 @@ Qed.
 
 (* Check context binding *)
 Ltac sym t :=
-  match constr:t with
+  match constr:(t) with
   | context C[(?X1 = ?X2)] => context C [X1 = X2]
   end.
 
@@ -143,7 +143,7 @@ Qed.
 
 Ltac check_binding y := cut ((fun y => y) = S).
 Goal True.
-check_binding ipattern:H.
+check_binding ipattern:(H).
 Abort.
 
 (* Check that variables explicitly parsed as ltac variables are not
@@ -151,7 +151,7 @@ Abort.
 
 Ltac afi tac := intros; tac.
 Goal 1 = 2.
-afi ltac:auto.
+afi ltac:(auto).
 Abort.
 
 (* Tactic Notation avec listes *)
@@ -174,7 +174,7 @@ Abort.
    empty args *)
 
 Goal True.
-match constr:@None with @None => exact I end.
+match constr:(@None) with @None => exact I end.
 Abort.
 
 (* Check second-order pattern unification *)
@@ -218,7 +218,7 @@ Ltac Z1 t := set (x:=t).
 Ltac Z2 t := t.
 Goal True -> True.
 Z1 O.
-Z2 ltac:O.
+Z2 ltac:(O).
 exact I.
 Qed.
 
@@ -302,7 +302,7 @@ Abort.
 (* Check instantiation of binders using ltac names *)
 
 Goal True.
-let x := ipattern:y in assert (forall x y, x = y + 0).
+let x := ipattern:(y) in assert (forall x y, x = y + 0).
 intro.
 destruct y. (* Check that the name is y here *)
 Abort.
diff --git a/test-suite/success/ltacprof.v b/test-suite/success/ltacprof.v
new file mode 100644
index 00000000..d5552695
--- /dev/null
+++ b/test-suite/success/ltacprof.v
@@ -0,0 +1,8 @@
+(** Some LtacProf tests *)
+
+Set Ltac Profiling.
+Ltac multi := (idtac + idtac).
+Goal True.
+  try (multi; fail). (* Used to result in: Anomaly: Uncaught exception Failure("hd"). Please report. *)
+Admitted.
+Show Ltac Profile.
diff --git a/test-suite/success/onlyprinting.v b/test-suite/success/onlyprinting.v
new file mode 100644
index 00000000..91a628d7
--- /dev/null
+++ b/test-suite/success/onlyprinting.v
@@ -0,0 +1,7 @@
+Notation "x ++ y" := (plus x y) (only printing).
+
+Fail Check 0 ++ 0.
+
+Notation "x + y" := (max x y) (only printing).
+
+Check (eq_refl : 42 + 18 = 60).
diff --git a/test-suite/success/par_abstract.v b/test-suite/success/par_abstract.v
new file mode 100644
index 00000000..7f6f9d62
--- /dev/null
+++ b/test-suite/success/par_abstract.v
@@ -0,0 +1,25 @@
+Axiom T : Type.
+
+Lemma foo : True * Type.
+Proof.
+  split.
+  par: abstract (exact I || exact T).
+Defined.
+
+(* Yes, these names are generated hence
+   the test is fragile.  I want to assert
+   that abstract was correctly handled
+   by par: *)
+Check foo_subproof.
+Check foo_subproof0.
+Check (refl_equal _ :
+  foo =
+  pair foo_subproof foo_subproof0).
+
+Lemma bar : True * Type.
+Proof.
+  split.
+  par: (exact I || exact T).
+Defined.
+Check (refl_equal _ :
+  bar = pair I T).
diff --git a/test-suite/success/paralleltac.v b/test-suite/success/paralleltac.v
index 94ff96ef..d25fd32a 100644
--- a/test-suite/success/paralleltac.v
+++ b/test-suite/success/paralleltac.v
@@ -1,3 +1,17 @@
+Lemma test_nofail_like_all1 :
+  True /\ False.
+Proof.
+split.
+all: trivial.
+Admitted.
+
+Lemma test_nofail_like_all2 :
+  True /\ False.
+Proof.
+split.
+par: trivial.
+Admitted.
+
 Fixpoint fib n := match n with
   | O => 1
   | S m => match m with
@@ -19,28 +33,28 @@ 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.
+Time all: solve [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.
+Time par: solve [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).
+Fail Time all: solve solve_P.
+all: solve [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).
+Fail Time par: solve [solve_P].
+all: solve [apply (P_triv Type)].
 Qed.
diff --git a/test-suite/success/primitiveproj.v b/test-suite/success/primitiveproj.v
index 281d707c..2fa77049 100644
--- a/test-suite/success/primitiveproj.v
+++ b/test-suite/success/primitiveproj.v
@@ -35,10 +35,6 @@ 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.
@@ -49,19 +45,11 @@ 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.
+Proof. Fail reflexivity. Abort.
 
-Lemma eta_ind'  (y: Y) : Some (yn 100 y) = Some {| next := (yn 100 y).(next) |}.
-Proof. reflexivity. Defined.
+Inductive Fdef := { Fa : nat ; Fb := Fa; Fc : Fdef }.
 
+Fail Scheme Fdef_rec := Induction for Fdef Sort Prop.
 
 (* 
   Rules for parsing and printing of primitive projections and their eta expansions.
diff --git a/test-suite/success/programequality.v b/test-suite/success/programequality.v
new file mode 100644
index 00000000..414c572f
--- /dev/null
+++ b/test-suite/success/programequality.v
@@ -0,0 +1,13 @@
+Require Import Program.
+
+Axiom t : nat -> Set.
+
+Goal forall (x y : nat) (e : x = y) (e' : x = y) (P : t y -> x = y -> Type)
+       (a : t x),
+    P (eq_rect _ _ a _ e) e'.
+Proof.
+  intros.
+  pi_eq_proofs. clear e.
+  destruct e'. simpl.
+  change (P a eq_refl).
+Abort.
\ No newline at end of file
diff --git a/test-suite/success/remember.v b/test-suite/success/remember.v
index 0befe054..b26a9ff1 100644
--- a/test-suite/success/remember.v
+++ b/test-suite/success/remember.v
@@ -14,3 +14,16 @@ let name := fresh "fresh" in
 remember (1 + 2) as x eqn:name.
 rewrite fresh.
 Abort.
+
+(* An example which was working in 8.4 but failing in 8.5 and 8.5pl1 *)
+                  
+Module A.
+Axiom N : nat.
+End A.
+Module B.
+Include A.
+End B.
+Goal id A.N = B.N.
+reflexivity.
+Qed.           
+                
diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v
index 0465c4b3..1f24ef2a 100644
--- a/test-suite/success/setoid_test.v
+++ b/test-suite/success/setoid_test.v
@@ -166,3 +166,16 @@ Proof. intros. setoid_rewrite <- foo_prf. change (beq_nat x 0 = y). Abort.
 Goal forall (x : nat) (y : bool), beq_nat (foo_neg x) 0 = foo_neg y.
 Proof. intros. setoid_rewrite <- @foo_prf at 1. change (beq_nat x 0 = foo_neg y). Abort.
 
+(* This should not raise an anomaly as it did for some time in early 2016 *)
+
+Definition t := nat -> bool.
+Definition h (a b : t) := forall n, a n = b n.
+
+Instance subrelh : subrelation h (Morphisms.pointwise_relation nat eq).
+Proof. intros x y H; assumption. Qed.
+
+Goal forall a b, h a b -> a 0 = b 0.
+intros.
+setoid_rewrite H. (* Fallback on ordinary rewrite without anomaly *)
+reflexivity.
+Qed.
diff --git a/test-suite/success/shrink_abstract.v b/test-suite/success/shrink_abstract.v
new file mode 100644
index 00000000..3f6b9cb3
--- /dev/null
+++ b/test-suite/success/shrink_abstract.v
@@ -0,0 +1,13 @@
+Set Shrink Abstract.
+
+Definition foo : forall (n m : nat), bool.
+Proof.
+pose (p := 0).
+intros n.
+pose (q := n).
+intros m.
+pose (r := m).
+abstract (destruct m; [left|right]).
+Defined.
+
+Check (foo_subproof : nat -> bool).
diff --git a/test-suite/success/shrink_obligations.v b/test-suite/success/shrink_obligations.v
new file mode 100644
index 00000000..676b9787
--- /dev/null
+++ b/test-suite/success/shrink_obligations.v
@@ -0,0 +1,28 @@
+Require Program.
+
+Obligation Tactic := idtac.
+
+Set Shrink Obligations.
+
+Program Definition foo (m : nat) (p := S m) (n : nat) (q := S n) : unit :=
+let bar : {r | n < r} := _ in
+let qux : {r | p < r} := _ in
+let quz : m = n -> True := _ in
+tt.
+Next Obligation.
+intros m p n q.
+exists (S n); constructor.
+Qed.
+Next Obligation.
+intros m p n q.
+exists (S (S m)); constructor.
+Qed.
+Next Obligation.
+intros m p n q ? ? H.
+destruct H.
+constructor.
+Qed.
+
+Check (foo_obligation_1 : forall n, {r | n < r}).
+Check (foo_obligation_2 : forall m, {r | (S m) < r}).
+Check (foo_obligation_3 : forall m n, m = n -> True).
diff --git a/test-suite/success/simpl_tuning.v b/test-suite/success/simpl_tuning.v
index d4191b93..2728672f 100644
--- a/test-suite/success/simpl_tuning.v
+++ b/test-suite/success/simpl_tuning.v
@@ -106,7 +106,7 @@ match goal with |- (f (g x1), h x2) = (f (g x1), h x2) => idtac end.
 Abort. 
 
 Definition volatile := fun x : nat => x.
-Arguments volatile /.
+Arguments volatile / _.
 
 Lemma foo : volatile = volatile.
 simpl.
diff --git a/test-suite/success/specialize.v b/test-suite/success/specialize.v
index 3faa1ca4..fba05cd9 100644
--- a/test-suite/success/specialize.v
+++ b/test-suite/success/specialize.v
@@ -64,3 +64,11 @@ assert (H:=H I).
 match goal with H:_ |- _ => clear H end.
 match goal with H:_ |- _ => exact H end.
 Qed.
+
+(* Test specialize as *)
+
+Goal (forall x, x=0) -> 1=0.
+intros.
+specialize (H 1) as ->.
+reflexivity.
+Qed.
diff --git a/test-suite/success/ssrpattern.v b/test-suite/success/ssrpattern.v
new file mode 100644
index 00000000..96f0bbac
--- /dev/null
+++ b/test-suite/success/ssrpattern.v
@@ -0,0 +1,22 @@
+Require Import ssrmatching.
+
+(*Set Debug SsrMatching.*)
+
+Tactic Notation "at" "[" ssrpatternarg(pat) "]" tactic(t) :=
+  let name := fresh in
+  let def_name := fresh in
+  ssrpattern pat;
+  intro name;
+  pose proof (refl_equal name) as def_name;
+  unfold name at 1 in def_name;
+  t def_name;
+  [ rewrite <- def_name | idtac.. ];
+  clear name def_name.
+
+Lemma test (H : True -> True -> 3 = 7) : 28 = 3 * 4.
+Proof.
+at [ X in X * 4 ] ltac:(fun place => rewrite -> H in place).
+- reflexivity.
+- trivial.
+- trivial.
+Qed.
diff --git a/test-suite/success/subst.v b/test-suite/success/subst.v
new file mode 100644
index 00000000..25ee81b5
--- /dev/null
+++ b/test-suite/success/subst.v
@@ -0,0 +1,42 @@
+(* Test various subtleties of the "subst" tactics *)
+
+(* Should proceed from left to right (see #4222) *)
+Goal forall x y, x = y -> x = 3 -> y = 2 -> x = y.
+intros.
+subst.
+change (3 = 2) in H1.
+change (3 = 3).
+Abort.
+
+(* Should work with "x = y" and "x = t" equations (see #4214, failed in 8.4) *)
+Goal forall x y, x = y -> x = 3 -> x = y.
+intros.
+subst.
+change (3 = 3).
+Abort.
+
+(* Should substitute cycles once, until a recursive equation is obtained *)
+(* (failed in 8.4) *)
+Goal forall x y, x = S y -> y = S x -> x = y.
+intros.
+subst.
+change (y = S (S y)) in H0.
+change (S y = y).
+Abort.
+
+(* A bug revealed by OCaml 4.03 warnings *)
+(* fixes in 4e3d464 and 89ec88f for v8.5, 4e3d4646 and 89ec88f1e for v8.6 *)
+Goal forall y, let x:=0 in y=x -> y=y.
+intros * H;
+(* This worked as expected *)
+subst.
+Fail clear H.
+Abort.
+
+Goal forall y, let x:=0 in x=y -> y=y.
+intros * H;
+(* Before the fix, this unfolded x instead of 
+   substituting y and erasing H *)
+subst.
+Fail clear H.
+Abort.
diff --git a/test-suite/success/univers.v b/test-suite/success/univers.v
index e00701fb..269359ae 100644
--- a/test-suite/success/univers.v
+++ b/test-suite/success/univers.v
@@ -60,3 +60,20 @@ Qed.
 (* Submitted by Danko Ilik (bug report #1507); related to LetIn *)
 
 Record U : Type := { A:=Type; a:A }.
+
+(** Check assignement of sorts to inductives and records. *)
+
+Variable sh : list nat.
+
+Definition is_box_in_shape (b :nat * nat) := True.
+Definition myType := Type.
+
+Module Ind.
+Inductive box_in : myType :=
+  myBox (coord : nat * nat) (_ : is_box_in_shape coord) : box_in.
+End Ind.
+
+Module Rec.
+Record box_in : myType :=
+  BoxIn { coord :> nat * nat; _ : is_box_in_shape coord }.
+End Rec.
\ No newline at end of file
diff --git a/test-suite/success/vm_univ_poly.v b/test-suite/success/vm_univ_poly.v
index 58fa3974..62df96c0 100644
--- a/test-suite/success/vm_univ_poly.v
+++ b/test-suite/success/vm_univ_poly.v
@@ -38,8 +38,8 @@ Definition _4 : sumbool_copy x = x :=
 
 (* Polymorphic Inductive Types *)
 Polymorphic Inductive poption@{i} (T : Type@{i}) : Type@{i} :=
-| PSome : T -> poption@{i} T
-| PNone : poption@{i} T.
+| PSome : T -> poption T
+| PNone : poption T.
 
 Polymorphic Definition poption_default@{i} {T : Type@{i}} (p : poption@{i} T) (x : T) : T :=
   match p with
@@ -49,7 +49,7 @@ Polymorphic Definition poption_default@{i} {T : Type@{i}} (p : poption@{i} T) (x
 
 Polymorphic Inductive plist@{i} (T : Type@{i}) : Type@{i} :=
 | pnil
-| pcons : T -> plist@{i} T -> plist@{i} T.
+| pcons : T -> plist T -> plist T.
 
 Arguments pnil {_}.
 Arguments pcons {_} _ _.
@@ -59,7 +59,7 @@ Polymorphic Definition pmap@{i j}
   fix pmap (ls : plist@{i} T) : plist@{j} U :=
     match ls with
     | @pnil _ => @pnil _
-    | @pcons _ l ls => @pcons@{j} U (f l) (pmap@{i j} ls)
+    | @pcons _ l ls => @pcons@{j} U (f l) (pmap ls)
     end.
 
 Universe Ubool.
@@ -75,7 +75,7 @@ Eval vm_compute in pmap (fun x => x -> Type) (pcons tbool (pcons (plist tbool) p
 
 Polymorphic Inductive Tree@{i} (T : Type@{i}) : Type@{i} :=
 | Empty
-| Branch : plist@{i} (Tree@{i} T) -> Tree@{i} T.
+| Branch : plist@{i} (Tree T) -> Tree T.
 
 Polymorphic Definition pfold@{i u}
             {T : Type@{i}} {U : Type@{u}} (f : T -> U -> U) :=
@@ -111,7 +111,7 @@ Polymorphic Fixpoint repeat@{i} {T : Type@{i}} (n : nat@{i}) (v : T) : plist@{i}
 Polymorphic Fixpoint big_tree@{i} (n : nat@{i}) : Tree@{i} nat@{i} :=
   match n with
   | O => @Empty nat@{i}
-  | S n' => Branch@{i} nat@{i} (repeat@{i} n' (big_tree@{i} n'))
+  | S n' => Branch@{i} nat@{i} (repeat@{i} n' (big_tree n'))
   end.
 
 Eval compute in height (big_tree (S (S (S O)))).
diff --git a/test-suite/typeclasses/open_constr.v b/test-suite/typeclasses/open_constr.v
new file mode 100644
index 00000000..5f1785c7
--- /dev/null
+++ b/test-suite/typeclasses/open_constr.v
@@ -0,0 +1,12 @@
+Tactic Notation "opose" open_constr(foo) := pose foo.
+Class Foo := Build_Foo : Set.
+Axiom f : forall `{Foo}, Set.
+Set Printing Implicit.
+Goal forall `{Foo}, True.
+Proof.
+  intro H.
+  pose f.
+  opose f.
+  Fail let x := (eval hnf in P) in has_evar x.
+  let x := (eval hnf in P0) in has_evar x.
+
diff --git a/test-suite/vio/print.v b/test-suite/vio/print.v
new file mode 100644
index 00000000..9c36a463
--- /dev/null
+++ b/test-suite/vio/print.v
@@ -0,0 +1,10 @@
+Lemma a : True.
+Proof.
+idtac.
+exact I.
+Qed.
+
+Print a.
+
+Lemma b : False.
+Admitted.
diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v
index f998e861..58d3a2b3 100644
--- a/theories/Arith/Between.v
+++ b/theories/Arith/Between.v
@@ -20,20 +20,20 @@ Section Between.
     | bet_emp : between k k
     | bet_S : forall l, between k l -> P l -> between k (S l).
 
-  Hint Constructors between: arith v62.
+  Hint Constructors between: arith.
 
   Lemma bet_eq : forall k l, l = k -> between k l.
   Proof.
     induction 1; auto with arith.
   Qed.
 
-  Hint Resolve bet_eq: arith v62.
+  Hint Resolve bet_eq: arith.
 
   Lemma between_le : forall k l, between k l -> k <= l.
   Proof.
     induction 1; auto with arith.
   Qed.
-  Hint Immediate between_le: arith v62.
+  Hint Immediate between_le: arith.
 
   Lemma between_Sk_l : forall k l, between k l -> S k <= l -> between (S k) l.
   Proof.
@@ -41,7 +41,7 @@ Section Between.
     intros; absurd (S k <= k); auto with arith.
     destruct H; auto with arith.
   Qed.
-  Hint Resolve between_Sk_l: arith v62.
+  Hint Resolve between_Sk_l: arith.
 
   Lemma between_restr :
     forall k l (m:nat), k <= l -> l <= m -> between k m -> between l m.
@@ -53,7 +53,7 @@ Section Between.
     | exists_S : forall l, exists_between k l -> exists_between k (S l)
     | exists_le : forall l, k <= l -> Q l -> exists_between k (S l).
 
-  Hint Constructors exists_between: arith v62.
+  Hint Constructors exists_between: arith.
 
   Lemma exists_le_S : forall k l, exists_between k l -> S k <= l.
   Proof.
@@ -62,13 +62,13 @@ Section Between.
 
   Lemma exists_lt : forall k l, exists_between k l -> k < l.
   Proof exists_le_S.
-  Hint Immediate exists_le_S exists_lt: arith v62.
+  Hint Immediate exists_le_S exists_lt: arith.
 
   Lemma exists_S_le : forall k l, exists_between k (S l) -> k <= l.
   Proof.
     intros; apply le_S_n; auto with arith.
   Qed.
-  Hint Immediate exists_S_le: arith v62.
+  Hint Immediate exists_S_le: arith.
 
   Definition in_int p q r := p <= r /\ r < q.
 
@@ -76,7 +76,7 @@ Section Between.
   Proof.
     red; auto with arith.
   Qed.
-  Hint Resolve in_int_intro: arith v62.
+  Hint Resolve in_int_intro: arith.
 
   Lemma in_int_lt : forall p q r, in_int p q r -> p < q.
   Proof.
@@ -95,13 +95,13 @@ Section Between.
   Proof.
     induction 1; auto with arith.
   Qed.
-  Hint Resolve in_int_S: arith v62.
+  Hint Resolve in_int_S: arith.
 
   Lemma in_int_Sp_q : forall p q r, in_int (S p) q r -> in_int p q r.
   Proof.
     induction 1; auto with arith.
   Qed.
-  Hint Immediate in_int_Sp_q: arith v62.
+  Hint Immediate in_int_Sp_q: arith.
 
   Lemma between_in_int :
     forall k l, between k l -> forall r, in_int k l r -> P r.
@@ -183,5 +183,5 @@ Section Between.
 End Between.
 
 Hint Resolve nth_O bet_S bet_emp bet_eq between_Sk_l exists_S exists_le
-  in_int_S in_int_intro: arith v62.
-Hint Immediate in_int_Sp_q exists_le_S exists_S_le: arith v62.
+  in_int_S in_int_intro: arith.
+Hint Immediate in_int_Sp_q exists_le_S exists_S_le: arith.
diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v
index 206fc0ab..f998c19f 100644
--- a/theories/Arith/EqNat.v
+++ b/theories/Arith/EqNat.v
@@ -25,7 +25,7 @@ Theorem eq_nat_refl n : eq_nat n n.
 Proof.
   induction n; simpl; auto.
 Qed.
-Hint Resolve eq_nat_refl: arith v62.
+Hint Resolve eq_nat_refl: arith.
 
 (** [eq] restricted to [nat] and [eq_nat] are equivalent *)
 
@@ -46,7 +46,7 @@ Proof.
  apply eq_nat_is_eq.
 Qed.
 
-Hint Immediate eq_eq_nat eq_nat_eq: arith v62.
+Hint Immediate eq_eq_nat eq_nat_eq: arith.
 
 Theorem eq_nat_elim :
   forall n (P:nat -> Prop), P n -> forall m, eq_nat n m -> P m.
diff --git a/theories/Arith/Gt.v b/theories/Arith/Gt.v
index dfd57694..67c94fdf 100644
--- a/theories/Arith/Gt.v
+++ b/theories/Arith/Gt.v
@@ -133,14 +133,14 @@ 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.
+Hint Resolve gt_Sn_O gt_Sn_n gt_n_S : arith.
+Hint Immediate gt_S_n gt_pred : arith.
+Hint Resolve gt_irrefl gt_asym : arith.
+Hint Resolve le_not_gt gt_not_le : arith.
+Hint Immediate le_S_gt gt_S_le : arith.
+Hint Resolve gt_le_S le_gt_S : arith.
+Hint Resolve gt_trans_S le_gt_trans gt_le_trans: arith.
+Hint Resolve plus_gt_compat_l: arith.
 
 (* begin hide *)
 Notation gt_O_eq := gt_0_eq (only parsing).
diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v
index ceb91187..0fbcec57 100644
--- a/theories/Arith/Le.v
+++ b/theories/Arith/Le.v
@@ -30,8 +30,8 @@ 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").
 
-Hint Resolve le_trans: arith v62.
-Hint Immediate le_antisym: arith v62.
+Hint Resolve le_trans: arith.
+Hint Immediate le_antisym: arith.
 
 (** * Properties of [le] w.r.t 0 *)
 
@@ -59,16 +59,16 @@ 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 Nat.lt_le_incl.
 
-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.
+Hint Resolve le_0_n le_Sn_0: arith.
+Hint Resolve le_n_S le_n_Sn le_Sn_n : arith.
+Hint Immediate le_n_0_eq le_Sn_le le_S_n : arith.
 
 (** * Properties of [le] w.r.t 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 *)
 
-Hint Resolve le_pred_n: arith v62.
+Hint Resolve le_pred_n: arith.
 
 (** * A different elimination principle for the order on natural numbers *)
 
diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v
index f824ee6f..bfc2b91a 100644
--- a/theories/Arith/Lt.v
+++ b/theories/Arith/Lt.v
@@ -25,7 +25,7 @@ Local Open Scope nat_scope.
 
 Notation lt_irrefl := Nat.lt_irrefl (compat "8.4"). (* ~ x < x *)
 
-Hint Resolve lt_irrefl: arith v62.
+Hint Resolve lt_irrefl: arith.
 
 (** * Relationship between [le] and [lt] *)
 
@@ -44,9 +44,9 @@ Proof.
  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.
+Hint Immediate lt_le_S: arith.
+Hint Immediate lt_n_Sm_le: arith.
+Hint Immediate le_lt_n_Sm: arith.
 
 Theorem le_not_lt n m : n <= m -> ~ m < n.
 Proof.
@@ -58,7 +58,7 @@ Proof.
  apply Nat.lt_nge.
 Qed.
 
-Hint Immediate le_not_lt lt_not_le: arith v62.
+Hint Immediate le_not_lt lt_not_le: arith.
 
 (** * Asymmetry *)
 
@@ -79,8 +79,8 @@ Proof.
  intros. now apply Nat.neq_sym, Nat.neq_0_lt_0.
 Qed.
 
-Hint Resolve lt_0_Sn lt_n_0 : arith v62.
-Hint Immediate neq_0_lt lt_0_neq: arith v62.
+Hint Resolve lt_0_Sn lt_n_0 : arith.
+Hint Immediate neq_0_lt lt_0_neq: arith.
 
 (** * Order and successor *)
 
@@ -97,8 +97,8 @@ Proof.
  apply Nat.succ_lt_mono.
 Qed.
 
-Hint Resolve lt_n_Sn lt_S lt_n_S : arith v62.
-Hint Immediate lt_S_n : arith v62.
+Hint Resolve lt_n_Sn lt_S lt_n_S : arith.
+Hint Immediate lt_S_n : arith.
 
 (** * Predecessor *)
 
@@ -117,8 +117,8 @@ 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.
+Hint Immediate lt_pred: arith.
+Hint Resolve lt_pred_n_n: arith.
 
 (** * Transitivity properties *)
 
@@ -126,7 +126,7 @@ 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.
+Hint Resolve lt_trans lt_le_trans le_lt_trans: arith.
 
 (** * Large = strict or equal *)
 
@@ -139,7 +139,7 @@ Qed.
 
 Notation lt_le_weak := Nat.lt_le_incl (compat "8.4").
 
-Hint Immediate lt_le_weak: arith v62.
+Hint Immediate lt_le_weak: arith.
 
 (** * Dichotomy *)
 
diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v
index 65534b2e..49152549 100644
--- a/theories/Arith/Max.v
+++ b/theories/Arith/Max.v
@@ -42,7 +42,7 @@ Notation max_SS := Nat.succ_max_distr (only parsing).
 (* end hide *)
 
 Hint Resolve
- Nat.max_l Nat.max_r Nat.le_max_l Nat.le_max_r : arith v62.
+ Nat.max_l Nat.max_r Nat.le_max_l Nat.le_max_r : arith.
 
 Hint Resolve
- Nat.min_l Nat.min_r Nat.le_min_l Nat.le_min_r : arith v62.
+ Nat.min_l Nat.min_r Nat.le_min_l Nat.le_min_r : arith.
diff --git a/theories/Arith/Minus.v b/theories/Arith/Minus.v
index bc3a318c..1fc8f790 100644
--- a/theories/Arith/Minus.v
+++ b/theories/Arith/Minus.v
@@ -107,13 +107,13 @@ Qed.
 
 (** * Hints *)
 
-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.
+Hint Resolve minus_n_O: arith.
+Hint Resolve minus_Sn_m: arith.
+Hint Resolve minus_diag_reverse: arith.
+Hint Resolve minus_plus_simpl_l_reverse: arith.
+Hint Immediate plus_minus: arith.
+Hint Resolve minus_plus: arith.
+Hint Resolve le_plus_minus: arith.
+Hint Resolve le_plus_minus_r: arith.
+Hint Resolve lt_minus: arith.
+Hint Immediate lt_O_minus_lt: arith.
diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v
index 96581243..a173efc1 100644
--- a/theories/Arith/Mult.v
+++ b/theories/Arith/Mult.v
@@ -31,13 +31,13 @@ Notation mult_0_r := Nat.mul_0_r (compat "8.4"). (* n * 0 = 0 *)
 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 *)
 
-Hint Resolve mult_1_l mult_1_r: arith v62.
+Hint Resolve mult_1_l mult_1_r: arith.
 
 (** ** Commutativity *)
 
 Notation mult_comm := Nat.mul_comm (compat "8.4"). (* n * m = m * n *)
 
-Hint Resolve mult_comm: arith v62.
+Hint Resolve mult_comm: arith.
 
 (** ** Distributivity *)
 
@@ -53,9 +53,9 @@ Notation mult_minus_distr_r :=
 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.
+Hint Resolve mult_plus_distr_r: arith.
+Hint Resolve mult_minus_distr_r: arith.
+Hint Resolve mult_minus_distr_l: arith.
 
 (** ** Associativity *)
 
@@ -66,8 +66,8 @@ Proof.
  symmetry. apply Nat.mul_assoc.
 Qed.
 
-Hint Resolve mult_assoc_reverse: arith v62.
-Hint Resolve mult_assoc: arith v62.
+Hint Resolve mult_assoc_reverse: arith.
+Hint Resolve mult_assoc: arith.
 
 (** ** Inversion lemmas *)
 
@@ -92,7 +92,7 @@ Lemma mult_O_le n m : m = 0 \/ n <= m * n.
 Proof.
  destruct m; [left|right]; simpl; trivial using Nat.le_add_r.
 Qed.
-Hint Resolve mult_O_le: arith v62.
+Hint Resolve mult_O_le: arith.
 
 Lemma mult_le_compat_l n m p : n <= m -> p * n <= p * m.
 Proof.
diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v
index 340a7968..f8020a50 100644
--- a/theories/Arith/Peano_dec.v
+++ b/theories/Arith/Peano_dec.v
@@ -38,8 +38,7 @@ 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.
+clear n; intros n [= <-] le_mn1 le_mn2.
 pose (def_n2 := eq_refl n0); transitivity (eq_ind _ _ le_mn2 _ def_n2).
   2: reflexivity.
 generalize def_n2; revert le_mn1 le_mn2.
@@ -50,7 +49,7 @@ destruct le_mn1; intros le_mn2; destruct le_mn2.
   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 ->.
++ intros def_n0. injection def_n0 as ->.
   rewrite (UIP_nat _ _ def_n0 eq_refl); simpl.
   assert (H : le_mn1 = le_mn2).
     now apply IHn0.
diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v
index 3b823da6..600e5e51 100644
--- a/theories/Arith/Plus.v
+++ b/theories/Arith/Plus.v
@@ -177,12 +177,12 @@ 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.
+Hint Immediate plus_comm : arith.
+Hint Resolve plus_assoc plus_assoc_reverse : arith.
+Hint Resolve plus_le_compat_l plus_le_compat_r : arith.
+Hint Resolve le_plus_l le_plus_r le_plus_trans : arith.
+Hint Immediate lt_plus_trans : arith.
+Hint Resolve plus_lt_compat_l plus_lt_compat_r : arith.
 
 (** For compatibility, we "Require" the same files as before *)
 
diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v
index 721ab693..06096c66 100644
--- a/theories/Bool/Bool.v
+++ b/theories/Bool/Bool.v
@@ -39,13 +39,13 @@ Lemma diff_true_false : true <> false.
 Proof.
   discriminate.
 Qed.
-Hint Resolve diff_true_false : bool v62.
+Hint Resolve diff_true_false : bool.
 
 Lemma diff_false_true : false <> true.
 Proof.
   discriminate.
 Qed.
-Hint Resolve diff_false_true : bool v62.
+Hint Resolve diff_false_true : bool.
 Hint Extern 1 (false <> true) => exact diff_false_true.
 
 Lemma eq_true_false_abs : forall b:bool, b = true -> b = false -> False.
@@ -82,7 +82,7 @@ Definition leb (b1 b2:bool) :=
     | true => b2 = true
     | false => True
   end.
-Hint Unfold leb: bool v62.
+Hint Unfold leb: bool.
 
 Lemma leb_implb : forall b1 b2, leb b1 b2 <-> implb b1 b2 = true.
 Proof.
@@ -242,14 +242,14 @@ Lemma orb_true_intro :
 Proof.
  intros; apply orb_true_iff; trivial.
 Qed.
-Hint Resolve orb_true_intro: bool v62.
+Hint Resolve orb_true_intro: bool.
 
 Lemma orb_false_intro :
   forall b1 b2:bool, b1 = false -> b2 = false -> b1 || b2 = false.
 Proof.
  intros. subst. reflexivity.
 Qed.
-Hint Resolve orb_false_intro: bool v62.
+Hint Resolve orb_false_intro: bool.
 
 Lemma orb_false_elim :
   forall b1 b2:bool, b1 || b2 = false -> b1 = false /\ b2 = false.
@@ -268,7 +268,7 @@ Lemma orb_true_r : forall b:bool, b || true = true.
 Proof.
   destr_bool.
 Qed.
-Hint Resolve orb_true_r: bool v62.
+Hint Resolve orb_true_r: bool.
 
 Lemma orb_true_l : forall b:bool, true || b = true.
 Proof.
@@ -284,13 +284,13 @@ Lemma orb_false_r : forall b:bool, b || false = b.
 Proof.
   destr_bool.
 Qed.
-Hint Resolve orb_false_r: bool v62.
+Hint Resolve orb_false_r: bool.
 
 Lemma orb_false_l : forall b:bool, false || b = b.
 Proof.
   destr_bool.
 Qed.
-Hint Resolve orb_false_l: bool v62.
+Hint Resolve orb_false_l: bool.
 
 Notation orb_b_false := orb_false_r (only parsing).
 Notation orb_false_b := orb_false_l (only parsing).
@@ -301,7 +301,7 @@ Lemma orb_negb_r : forall b:bool, b || negb b = true.
 Proof.
   destr_bool.
 Qed.
-Hint Resolve orb_negb_r: bool v62.
+Hint Resolve orb_negb_r: bool.
 
 Notation orb_neg_b := orb_negb_r (only parsing).
 
@@ -318,7 +318,7 @@ Lemma orb_assoc : forall b1 b2 b3:bool, b1 || (b2 || b3) = b1 || b2 || b3.
 Proof.
   destr_bool.
 Qed.
-Hint Resolve orb_comm orb_assoc: bool v62.
+Hint Resolve orb_comm orb_assoc: bool.
 
 (*******************************)
 (** * Properties of [andb]     *)
@@ -392,7 +392,7 @@ Lemma andb_false_elim :
 Proof.
   destruct b1; simpl; auto.
 Defined.
-Hint Resolve andb_false_elim: bool v62.
+Hint Resolve andb_false_elim: bool.
 
 (** Complementation *)
 
@@ -400,7 +400,7 @@ Lemma andb_negb_r : forall b:bool, b && negb b = false.
 Proof.
   destr_bool.
 Qed.
-Hint Resolve andb_negb_r: bool v62.
+Hint Resolve andb_negb_r: bool.
 
 Notation andb_neg_b := andb_negb_r (only parsing).
 
@@ -418,7 +418,7 @@ Proof.
   destr_bool.
 Qed.
 
-Hint Resolve andb_comm andb_assoc: bool v62.
+Hint Resolve andb_comm andb_assoc: bool.
 
 (*******************************************)
 (** * Properties mixing [andb] and [orb] *)
@@ -688,7 +688,7 @@ Lemma andb_prop_intro :
 Proof.
   destr_bool; tauto.
 Qed.
-Hint Resolve andb_prop_intro: bool v62.
+Hint Resolve andb_prop_intro: bool.
 
 Notation andb_true_intro2 :=
   (fun b1 b2 H1 H2 => andb_prop_intro b1 b2 (conj H1 H2))
@@ -699,7 +699,7 @@ Lemma andb_prop_elim :
 Proof.
   destr_bool; auto.
 Qed.
-Hint Resolve andb_prop_elim: bool v62.
+Hint Resolve andb_prop_elim: bool.
 
 Notation andb_prop2 := andb_prop_elim (only parsing).
 
diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v
index 11f3d1d6..4257b4bc 100644
--- a/theories/Bool/IfProp.v
+++ b/theories/Bool/IfProp.v
@@ -12,7 +12,7 @@ Inductive IfProp (A B:Prop) : bool -> Prop :=
   | Iftrue : A -> IfProp A B true
   | Iffalse : B -> IfProp A B false.
 
-Hint Resolve Iftrue Iffalse: bool v62.
+Hint Resolve Iftrue Iffalse: bool.
 
 Lemma Iftrue_inv : forall (A B:Prop) (b:bool), IfProp A B b -> b = true -> A.
 destruct 1; intros; auto with bool.
diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v
index c41eb2fa..1cfca416 100644
--- a/theories/Classes/CMorphisms.v
+++ b/theories/Classes/CMorphisms.v
@@ -452,7 +452,7 @@ 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]
+        [(do_partial_apps H m' ltac:(idtac))|clear H]
       | _ => cont
     end
   in
@@ -527,7 +527,7 @@ Hint Extern 7 (@Proper _ _ _) => proper_reflexive
 Section Normalize.
   Context (A : Type).
 
-  Class Normalizes (m : crelation A) (m' : crelation A) : Prop :=
+  Class Normalizes (m : crelation A) (m' : crelation A) :=
     normalizes : relation_equivalence m m'.
   
   (** Current strategy: add [flip] everywhere and reduce using [subrelation]
diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v
index c4588947..80b0b7e4 100644
--- a/theories/Classes/Equivalence.v
+++ b/theories/Classes/Equivalence.v
@@ -49,11 +49,11 @@ 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_reflexive `(sa : Equivalence A) : Reflexive equiv | 1.
 
-Program Instance equiv_symmetric `(sa : Equivalence A) : Symmetric equiv.
+Program Instance equiv_symmetric `(sa : Equivalence A) : Symmetric equiv | 1.
 
-Program Instance equiv_transitive `(sa : Equivalence A) : Transitive equiv.
+Program Instance equiv_transitive `(sa : Equivalence A) : Transitive equiv | 1.
 
   Next Obligation.
   Proof. intros A R sa x y z Hxy Hyz.
@@ -123,7 +123,7 @@ Section Respecting.
 
 End Respecting.
 
-(** The default equivalence on function spaces, with higher-priority than [eq]. *)
+(** 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.
diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v
index 8d942d90..06511ace 100644
--- a/theories/Classes/Morphisms.v
+++ b/theories/Classes/Morphisms.v
@@ -465,12 +465,12 @@ 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]
+        [(do_partial_apps H m' ltac:(idtac))|clear H]
       | _ => cont
     end
   in
   let rec do_partial H ar m := 
-    match ar with
+    lazymatch ar with
       | 0%nat => do_partial_apps H m ltac:(fail 1)
       | S ?n' =>
         match m with
@@ -483,7 +483,7 @@ Ltac partial_application_tactic :=
      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 ;
+        assert(H:Params m' v) by (subst m'; once typeclasses eauto) ;
           let v' := eval compute in v in subst m';
             (sk H v' || fail 1))
     || fk
diff --git a/theories/Classes/RelationPairs.v b/theories/Classes/RelationPairs.v
index cbde5f9a..8d1c4982 100644
--- a/theories/Classes/RelationPairs.v
+++ b/theories/Classes/RelationPairs.v
@@ -43,6 +43,9 @@ Generalizable Variables A B RA RB Ri Ro f.
 Definition RelCompFun {A} {B : Type}(R:relation B)(f:A->B) : relation A :=
  fun a a' => R (f a) (f a').
 
+(** Instances on RelCompFun must match syntactically *)
+Typeclasses Opaque RelCompFun. 
+
 Infix "@@" := RelCompFun (at level 30, right associativity) : signature_scope.
 
 Notation "R @@1" := (R @@ Fst)%signature (at level 30) : signature_scope.
@@ -65,6 +68,8 @@ Instance snd_measure : @Measure (A * B) B Snd.
 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).
 
+Typeclasses Opaque RelProd.
+
 Infix "*" := RelProd : signature_scope.
 
 Section RelCompFun_Instances.
diff --git a/theories/Classes/SetoidTactics.v b/theories/Classes/SetoidTactics.v
index 145d451f..190397ae 100644
--- a/theories/Classes/SetoidTactics.v
+++ b/theories/Classes/SetoidTactics.v
@@ -77,23 +77,23 @@ Tactic Notation "setoid_replace" constr(x) "with" constr(y)
 
 Tactic Notation "setoid_replace" constr(x) "with" constr(y)
   "by" tactic3(t) :=
-  setoidreplace (default_relation x y) ltac:t.
+  setoidreplace (default_relation x y) ltac:(t).
 
 Tactic Notation "setoid_replace" constr(x) "with" constr(y)
   "at" int_or_var_list(o)
   "by" tactic3(t) :=
-  setoidreplaceat (default_relation x y) ltac:t o.
+  setoidreplaceat (default_relation x y) ltac:(t) o.
 
 Tactic Notation "setoid_replace" constr(x) "with" constr(y)
   "in" hyp(id)
   "by" tactic3(t) :=
-  setoidreplacein (default_relation x y) id ltac:t.
+  setoidreplacein (default_relation x y) id ltac:(t).
 
 Tactic Notation "setoid_replace" constr(x) "with" constr(y)
   "in" hyp(id)
   "at" int_or_var_list(o)
   "by" tactic3(t) :=
-  setoidreplaceinat (default_relation x y) id ltac:t o.
+  setoidreplaceinat (default_relation x y) id ltac:(t) o.
 
 Tactic Notation "setoid_replace" constr(x) "with" constr(y)
   "using" "relation" constr(rel) :=
@@ -107,13 +107,13 @@ Tactic Notation "setoid_replace" constr(x) "with" constr(y)
 Tactic Notation "setoid_replace" constr(x) "with" constr(y)
   "using" "relation" constr(rel)
   "by" tactic3(t) :=
-  setoidreplace (rel x y) ltac:t.
+  setoidreplace (rel x y) ltac:(t).
 
 Tactic Notation "setoid_replace" constr(x) "with" constr(y)
   "using" "relation" constr(rel)
   "at" int_or_var_list(o)
   "by" tactic3(t) :=
-  setoidreplaceat (rel x y) ltac:t o.
+  setoidreplaceat (rel x y) ltac:(t) o.
 
 Tactic Notation "setoid_replace" constr(x) "with" constr(y)
   "using" "relation" constr(rel)
@@ -130,14 +130,14 @@ Tactic Notation "setoid_replace" constr(x) "with" constr(y)
   "using" "relation" constr(rel)
   "in" hyp(id)
   "by" tactic3(t) :=
-  setoidreplacein (rel x y) id ltac:t.
+  setoidreplacein (rel x y) id ltac:(t).
 
 Tactic Notation "setoid_replace" constr(x) "with" constr(y)
   "using" "relation" constr(rel)
   "in" hyp(id)
   "at" int_or_var_list(o)
   "by" tactic3(t) :=
-  setoidreplaceinat (rel x y) id ltac:t o.
+  setoidreplaceinat (rel x y) id ltac:(t) o.
 
 (** The [add_morphism_tactic] tactic is run at each [Add Morphism]
    command before giving the hand back to the user to discharge the
diff --git a/theories/Compat/Coq84.v b/theories/Compat/Coq84.v
index 90083b00..a3e23f91 100644
--- a/theories/Compat/Coq84.v
+++ b/theories/Compat/Coq84.v
@@ -7,6 +7,10 @@
 (************************************************************************)
 
 (** Compatibility file for making Coq act similar to Coq v8.4 *)
+
+(** Any compatibility changes to make future versions of Coq behave like Coq 8.5 are likely needed to make them behave like Coq 8.4. *)
+Require Export Coq.Compat.Coq85.
+
 (** See https://coq.inria.fr/bugs/show_bug.cgi?id=4319 for updates *)
 (** This is required in Coq 8.5 to use the [omega] tactic; in Coq 8.4, it's automatically available.  But ZArith_base puts infix ~ at level 7, and we don't want that, so we don't [Import] it. *)
 Require Coq.omega.Omega.
@@ -15,21 +19,31 @@ Ltac omega := Coq.omega.Omega.omega.
 (** The number of arguments given in [match] statements has changed from 8.4 to 8.5. *)
 Global Set Asymmetric Patterns.
 
+(** The automatic elimination schemes for records were dropped by default in 8.5.  This restores the default behavior of Coq 8.4. *)
+Global Set Nonrecursive Elimination Schemes.
+
 (** See bug 3545 *)
 Global Set Universal Lemma Under Conjunction.
 
-(** In 8.5, [refine] leaves over dependent subgoals. *)
-Tactic Notation "refine" uconstr(term) := refine term; shelve_unifiable.
+(** Feature introduced in 8.5, disabled by default and configurable since 8.6. *)
+Global Unset Refolding Reduction.
 
 (** In 8.4, [constructor (tac)] allowed backtracking across the use of [constructor]; it has been subsumed by [constructor; tac]. *)
-Ltac constructor_84 := constructor.
 Ltac constructor_84_n n := constructor n.
 Ltac constructor_84_tac tac := once (constructor; tac).
 
-Tactic Notation "constructor" := constructor_84.
+Tactic Notation "constructor" := Coq.Init.Notations.constructor.
 Tactic Notation "constructor" int_or_var(n) := constructor_84_n n.
 Tactic Notation "constructor" "(" tactic(tac) ")" := constructor_84_tac tac.
 
+(** In 8.4, [econstructor (tac)] allowed backtracking across the use of [econstructor]; it has been subsumed by [econstructor; tac]. *)
+Ltac econstructor_84_n n := econstructor n.
+Ltac econstructor_84_tac tac := once (econstructor; tac).
+
+Tactic Notation "econstructor" := Coq.Init.Notations.econstructor.
+Tactic Notation "econstructor" int_or_var(n) := econstructor_84_n n.
+Tactic Notation "econstructor" "(" tactic(tac) ")" := econstructor_84_tac tac.
+
 (** Some tactic notations do not factor well with tactics; we add global parsing entries for some tactics that would otherwise be overwritten by custom variants. See https://coq.inria.fr/bugs/show_bug.cgi?id=4392. *)
 Tactic Notation "reflexivity" := reflexivity.
 Tactic Notation "assumption" := assumption.
@@ -45,29 +59,21 @@ Tactic Notation "left" := left.
 Tactic Notation "eleft" := eleft.
 Tactic Notation "right" := right.
 Tactic Notation "eright" := eright.
-Tactic Notation "constructor" := constructor.
-Tactic Notation "econstructor" := econstructor.
 Tactic Notation "symmetry" := symmetry.
 Tactic Notation "split" := split.
 Tactic Notation "esplit" := esplit.
 
-Global Set Regular Subst Tactic.
-
-(** Some names have changed in the standard library, so we add aliases. *)
-Require Coq.ZArith.Int.
-Module Export Coq.
-  Module Export ZArith.
-    Module Int.
-      Module Z_as_Int.
-        Include Coq.ZArith.Int.Z_as_Int.
-        (* FIXME: Should these get a (compat "8.4")?  Or be moved to Z_as_Int, probably? *)
-        Notation plus := Coq.ZArith.Int.Z_as_Int.add (only parsing).
-        Notation minus := Coq.ZArith.Int.Z_as_Int.sub (only parsing).
-        Notation mult := Coq.ZArith.Int.Z_as_Int.mul (only parsing).
-      End Z_as_Int.
-    End Int.
-  End ZArith.
-End Coq.
-
 (** Many things now import [PeanoNat] rather than [NPeano], so we require it so that the old absolute names in [NPeano.Nat] are available. *)
 Require Coq.Numbers.Natural.Peano.NPeano.
+
+(** The following coercions were declared by default in Specif.v. *)
+Coercion sig_of_sig2 : sig2 >-> sig.
+Coercion sigT_of_sigT2 : sigT2 >-> sigT.
+Coercion sigT_of_sig : sig >-> sigT.
+Coercion sig_of_sigT : sigT >-> sig.
+Coercion sigT2_of_sig2 : sig2 >-> sigT2.
+Coercion sig2_of_sigT2 : sigT2 >-> sig2.
+
+(** In 8.4, the statement of admitted lemmas did not depend on the section
+    variables. *)
+Unset Keep Admitted Variables.
diff --git a/theories/Compat/Coq85.v b/theories/Compat/Coq85.v
index 6e2b3564..64ba6b1e 100644
--- a/theories/Compat/Coq85.v
+++ b/theories/Compat/Coq85.v
@@ -7,3 +7,30 @@
 (************************************************************************)
 
 (** Compatibility file for making Coq act similar to Coq v8.5 *)
+
+(** Any compatibility changes to make future versions of Coq behave like Coq 8.6
+    are likely needed to make them behave like Coq 8.5. *)
+Require Export Coq.Compat.Coq86.
+
+(** We use some deprecated options in this file, so we disable the
+    corresponding warning, to silence the build of this file. *)
+Local Set Warnings "-deprecated-option".
+
+(* In 8.5, "intros [|]", taken e.g. on a goal "A\/B->C", does not
+   behave as "intros [H|H]" but leave instead hypotheses quantified in
+   the goal, here producing subgoals A->C and B->C. *)
+
+Global Unset Bracketing Last Introduction Pattern.
+Global Unset Regular Subst Tactic.
+Global Unset Structural Injection.
+Global Unset Shrink Abstract.
+Global Unset Shrink Obligations.
+Global Set Refolding Reduction.
+
+(** The resolution algorithm for type classes has changed. *)
+Global Set Typeclasses Legacy Resolution.
+Global Set Typeclasses Limit Intros.
+Global Unset Typeclasses Filtered Unification.
+
+(** Allow silently letting unification constraints float after a "." *)
+Global Unset Solve Unification Constraints.
diff --git a/theories/Compat/Coq86.v b/theories/Compat/Coq86.v
new file mode 100644
index 00000000..6952fdf1
--- /dev/null
+++ b/theories/Compat/Coq86.v
@@ -0,0 +1,9 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Compatibility file for making Coq act similar to Coq v8.6 *)
\ No newline at end of file
diff --git a/theories/Compat/vo.itarget b/theories/Compat/vo.itarget
index 43b19700..7ffb86eb 100644
--- a/theories/Compat/vo.itarget
+++ b/theories/Compat/vo.itarget
@@ -1,3 +1,4 @@
 AdmitAxiom.vo
 Coq84.vo
 Coq85.vo
+Coq86.vo
diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v
index eaeb2914..3c5690a7 100644
--- a/theories/FSets/FMapFacts.v
+++ b/theories/FSets/FMapFacts.v
@@ -24,6 +24,8 @@ Hint Extern 1 (Equivalence _) => constructor; congruence.
 
 Module WFacts_fun (E:DecidableType)(Import M:WSfun E).
 
+Notation option_map := option_map (compat "8.4").
+
 Notation eq_dec := E.eq_dec.
 Definition eqb x y := if eq_dec x y then true else false.
 
@@ -1986,7 +1988,7 @@ Module OrdProperties (M:S).
   simpl; intros; try discriminate.
   intros.
   destruct a; destruct l; simpl in *.
-  injection H; clear H; intros; subst.
+  injection H as -> ->.
   inversion_clear H1.
   red in H; simpl in *; intuition.
   elim H0; eauto.
@@ -2050,10 +2052,10 @@ Module OrdProperties (M:S).
   generalize (elements_3 m).
   destruct (elements m).
   try discriminate.
-  destruct p; injection H; intros; subst.
-  inversion_clear H1.
+  destruct p; injection H as -> ->; intros H4.
+  inversion_clear H1 as [? ? H2|? ? H2].
   red in H2; destruct H2; simpl in *; ME.order.
-  inversion_clear H4.
+  inversion_clear H4. rename H1 into H3.
   rewrite (@InfA_alt _ eqke) in H3; eauto with *.
   apply (H3 (y,x0)); auto.
   Qed.
diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v
index 13cb559b..5acdb7eb 100644
--- a/theories/FSets/FMapList.v
+++ b/theories/FSets/FMapList.v
@@ -8,7 +8,7 @@
 
 (** * Finite map library *)
 
-(** This file proposes an implementation of the non-dependant interface
+(** This file proposes an implementation of the non-dependent interface
  [FMapInterface.S] using lists of pairs ordered (increasing) with respect to
  left projection. *)
 
diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v
index 9e59f0c5..b1c0fdaa 100644
--- a/theories/FSets/FMapPositive.v
+++ b/theories/FSets/FMapPositive.v
@@ -274,8 +274,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
         rewrite append_assoc_1; apply in_or_app; right; apply in_cons;
           apply IHm2; auto.
         rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto.
-        rewrite append_neutral_r; apply in_or_app; injection H;
-          intro EQ; rewrite EQ; right; apply in_eq.
+        rewrite append_neutral_r; apply in_or_app; injection H as ->;
+          right; apply in_eq.
         rewrite append_assoc_1; apply in_or_app; right; apply IHm2; auto.
         rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto.
         congruence.
@@ -315,7 +315,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
          apply in_or_app.
         left; apply IHm1; auto.
         right; destruct (in_inv H0).
-         injection H1; intros Eq1 Eq2; rewrite Eq1; rewrite Eq2; apply in_eq.
+         injection H1 as -> ->; apply in_eq.
          apply in_cons; apply IHm2; auto.
         left; apply IHm1; auto.
         right; apply IHm2; auto.
@@ -346,7 +346,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
          apply in_or_app.
         left; apply IHm1; auto.
         right; destruct (in_inv H0).
-         injection H1; intros Eq1 Eq2; rewrite Eq1; rewrite Eq2; apply in_eq.
+         injection H1 as -> ->; apply in_eq.
          apply in_cons; apply IHm2; auto.
         left; apply IHm1; auto.
         right; apply IHm2; auto.
@@ -689,7 +689,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst.
   red; red; simpl.
   destruct H0.
-  injection H0; clear H0; intros _ H0; subst.
+  injection H0 as H0 _; subst.
   eapply xelements_bits_lt_1; eauto.
   apply E.bits_lt_trans with p.
   eapply xelements_bits_lt_1; eauto.
diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v
index 0f11dd7a..130cbee8 100644
--- a/theories/FSets/FMapWeakList.v
+++ b/theories/FSets/FMapWeakList.v
@@ -8,7 +8,7 @@
 
 (** * Finite map library *)
 
-(** This file proposes an implementation of the non-dependant interface
+(** This file proposes an implementation of the non-dependent interface
  [FMapInterface.WS] using lists of pairs, unordered but without redundancy. *)
 
 Require Import FMapInterface.
diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v
index ad067eb3..1db6a71e 100644
--- a/theories/FSets/FSetDecide.v
+++ b/theories/FSets/FSetDecide.v
@@ -357,17 +357,8 @@ the above form:
         | _ => idtac
       end.
 
-    (** [if t then t1 else t2] executes [t] and, if it does not
-        fail, then [t1] will be applied to all subgoals
-        produced.  If [t] fails, then [t2] is executed. *)
-    Tactic Notation
-      "if" tactic(t)
-      "then" tactic(t1)
-      "else" tactic(t2) :=
-      first [ t; first [ t1 | fail 2 ] | t2 ].
-
     Ltac abstract_term t :=
-      if (is_var t) then fail "no need to abstract a variable"
+      tryif (is_var t) then fail "no need to abstract a variable"
       else (let x := fresh "x" in set (x := t) in *; try clearbody x).
 
     Ltac abstract_elements :=
@@ -478,11 +469,11 @@ the above form:
       repeat (
         match goal with
         | H : context [ @Logic.eq ?T ?x ?y ] |- _ =>
-          if (change T with E.t in H) then fail
-          else if (change T with t in H) then fail
+          tryif (change T with E.t in H) then fail
+          else tryif (change T with t in H) then fail
           else clear H
         | H : ?P |- _ =>
-          if prop (FSet_Prop P) holds by
+          tryif prop (FSet_Prop P) holds by
             (auto 100 with FSet_Prop)
           then fail
           else clear H
@@ -747,7 +738,7 @@ the above form:
     | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False =>
       contradict H; fsetdec_body
     | H: ?P -> False |- ?Q -> False =>
-      if prop (FSet_elt_Prop P) holds by
+      tryif prop (FSet_elt_Prop P) holds by
         (auto 100 with FSet_Prop)
       then (contradict H; fsetdec_body)
       else fsetdec_body
diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v
index 1f36306c..9c3ec71a 100644
--- a/theories/FSets/FSetList.v
+++ b/theories/FSets/FSetList.v
@@ -8,7 +8,7 @@
 
 (** * Finite sets library *)
 
-(** This file proposes an implementation of the non-dependant
+(** This file proposes an implementation of the non-dependent
     interface [FSetInterface.S] using strictly ordered list. *)
 
 Require Export FSetInterface.
diff --git a/theories/FSets/FSetPositive.v b/theories/FSets/FSetPositive.v
index 7398c6d6..507f1cda 100644
--- a/theories/FSets/FSetPositive.v
+++ b/theories/FSets/FSetPositive.v
@@ -1007,10 +1007,10 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
       destruct o.
         intros x H. injection H; intros; subst. reflexivity.
         revert IHl. case choose.
-          intros p Hp x H. injection H; intros; subst; clear H. apply Hp.
+          intros p Hp x H. injection H as <-. apply Hp.
            reflexivity.
           intros _ x. revert IHr. case choose.
-            intros p Hp H. injection H; intros; subst; clear H. apply Hp.
+            intros p Hp H. injection H as <-. apply Hp.
             reflexivity.
             intros. discriminate.
   Qed.
@@ -1066,11 +1066,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
    induction s as [| l IHl o r IHr]; simpl.
      intros. discriminate.
      intros x. destruct (min_elt l); intros.
-       injection H. intros <-. apply IHl. reflexivity.
+       injection H as <-. apply IHl. reflexivity.
        destruct o; simpl.
-         injection H. intros <-. reflexivity.
+         injection H as <-. reflexivity.
          destruct (min_elt r); simpl in *.
-           injection H. intros <-. apply IHr. reflexivity.
+           injection H as <-. apply IHr. reflexivity.
            discriminate.
   Qed.
 
@@ -1094,15 +1094,15 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
     induction s as [|l IHl o r IHr]; intros x y H H'.
       discriminate.
       simpl in H. case_eq (min_elt l).
-        intros p Hp. rewrite Hp in H. injection H; intros <-.
+        intros p Hp. rewrite Hp in H. injection H as <-.
         destruct y as [z|z|]; simpl; intro; trivial. apply (IHl p z); trivial.
         intro Hp; rewrite Hp in H. apply min_elt_3 in Hp.
         destruct o.
-          injection H. intros <- Hl. clear H.
+          injection H as <-. intros Hl.
           destruct y as [z|z|]; simpl; trivial. elim (Hp _ H').
 
           destruct (min_elt r).
-            injection H. intros <-. clear H.
+            injection H as <-.
             destruct y as [z|z|].
               apply (IHr e z); trivial.
               elim (Hp _ H').
@@ -1119,11 +1119,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
    induction s as [| l IHl o r IHr]; simpl.
      intros. discriminate.
      intros x. destruct (max_elt r); intros.
-       injection H. intros <-. apply IHr. reflexivity.
+       injection H as <-. apply IHr. reflexivity.
        destruct o; simpl.
-         injection H. intros <-. reflexivity.
+         injection H as <-. reflexivity.
          destruct (max_elt l); simpl in *.
-           injection H. intros <-. apply IHl. reflexivity.
+           injection H as <-. apply IHl. reflexivity.
            discriminate.
   Qed.
 
@@ -1147,15 +1147,15 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
     induction s as [|l IHl o r IHr]; intros x y H H'.
       discriminate.
       simpl in H. case_eq (max_elt r).
-        intros p Hp. rewrite Hp in H. injection H; intros <-.
+        intros p Hp. rewrite Hp in H. injection H as <-.
         destruct y as [z|z|]; simpl; intro; trivial. apply (IHr p z); trivial.
         intro Hp; rewrite Hp in H. apply max_elt_3 in Hp.
         destruct o.
-          injection H. intros <- Hl. clear H.
+          injection H as <-. intros Hl.
           destruct y as [z|z|]; simpl; trivial. elim (Hp _ H').
 
           destruct (max_elt l).
-            injection H. intros <-. clear H.
+            injection H as <-.
             destruct y as [z|z|].
               elim (Hp _ H').
               apply (IHl e z); trivial.
diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v
index 2ea32e97..9dbea884 100644
--- a/theories/FSets/FSetWeakList.v
+++ b/theories/FSets/FSetWeakList.v
@@ -8,7 +8,7 @@
 
 (** * Finite sets library *)
 
-(** This file proposes an implementation of the non-dependant
+(** This file proposes an implementation of the non-dependent
     interface [FSetInterface.WS] using lists without redundancy. *)
 
 Require Import FSetInterface.
diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v
index 4850c9ca..ddaf08bf 100644
--- a/theories/Init/Datatypes.v
+++ b/theories/Init/Datatypes.v
@@ -151,6 +151,7 @@ Inductive option (A:Type) : Type :=
   | Some : A -> option A
   | None : option A.
 
+Arguments Some {A} a.
 Arguments None {A}.
 
 Definition option_map (A B:Type) (f:A->B) (o : option A) : option B :=
@@ -225,6 +226,7 @@ Inductive list (A : Type) : Type :=
  | cons : A -> list A -> list A.
 
 Arguments nil {A}.
+Arguments cons {A} a l.
 Infix "::" := cons (at level 60, right associativity) : list_scope.
 Delimit Scope list_scope with list.
 Bind Scope list_scope with list.
diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v
index 4a5f2ad6..4536dfc0 100644
--- a/theories/Init/Logic_Type.v
+++ b/theories/Init/Logic_Type.v
@@ -64,7 +64,7 @@ Definition identity_rect_r :
  intros A x P H y H0; case identity_sym with (1 := H0); trivial.
 Defined.
 
-Hint Immediate identity_sym not_identity_sym: core v62.
+Hint Immediate identity_sym not_identity_sym: core.
 
 Notation refl_id := identity_refl (compat "8.3").
 Notation sym_id := identity_sym (compat "8.3").
diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v
index ab6bf472..48fbe079 100644
--- a/theories/Init/Notations.v
+++ b/theories/Init/Notations.v
@@ -76,17 +76,21 @@ Reserved Notation "{ x : A  & P }" (at level 0, x at level 99).
 Reserved Notation "{ x : A  & P  & Q }" (at level 0, x at level 99).
 
 Delimit Scope type_scope with type.
+Delimit Scope function_scope with function.
 Delimit Scope core_scope with core.
 
+Bind Scope type_scope with Sortclass.
+Bind Scope function_scope with Funclass.
+
 Open Scope core_scope.
+Open Scope function_scope.
 Open Scope type_scope.
 
 (** ML Tactic Notations *)
 
 Declare ML Module "coretactics".
 Declare ML Module "extratactics".
-Declare ML Module "eauto".
+Declare ML Module "g_auto".
 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 3749baf6..6c4a6350 100644
--- a/theories/Init/Peano.v
+++ b/theories/Init/Peano.v
@@ -33,7 +33,6 @@ Open Scope nat_scope.
 Definition eq_S := f_equal S.
 Definition f_equal_nat := f_equal (A:=nat).
 
-Hint Resolve eq_S: v62.
 Hint Resolve f_equal_nat: core.
 
 (** The predecessor function *)
@@ -41,7 +40,6 @@ Hint Resolve f_equal_nat: core.
 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.
@@ -85,7 +83,6 @@ Notation plus := Nat.add (compat "8.4").
 Infix "+" := Nat.add : nat_scope.
 
 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.
 
diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v
index 04a263ad..03f2328d 100644
--- a/theories/Init/Prelude.v
+++ b/theories/Init/Prelude.v
@@ -15,6 +15,7 @@ Require Coq.Init.Nat.
 Require Export Peano.
 Require Export Coq.Init.Wf.
 Require Export Coq.Init.Tactics.
+Require Export Coq.Init.Tauto.
 (* Initially available plugins
    (+ nat_syntax_plugin loaded in Datatypes) *)
 Declare ML Module "extraction_plugin".
diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v
index 6c022185..9fc00e80 100644
--- a/theories/Init/Specif.v
+++ b/theories/Init/Specif.v
@@ -9,6 +9,7 @@
 (** Basic specifications : sets that may contain logical information *)
 
 Set Implicit Arguments.
+Set Reversible Pattern Implicit.
 
 Require Import Notations.
 Require Import Datatypes.
@@ -298,7 +299,7 @@ Proof.
   apply (h2 h1).
 Defined.
 
-Hint Resolve left right inleft inright: core v62.
+Hint Resolve left right inleft inright: core.
 Hint Resolve exist exist2 existT existT2: core.
 
 (* Compatibility *)
diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v
index 59fdbb42..5d1e87ae 100644
--- a/theories/Init/Tactics.v
+++ b/theories/Init/Tactics.v
@@ -55,12 +55,6 @@ Ltac contradict H :=
    | _ => (elim H;fail) || pos H
   end.
 
-(* Transforming a negative goal [ H:~A |- ~B ] into a positive one [ B |- A ]*)
-
-Ltac swap H :=
-  idtac "swap is OBSOLETE: use contradict instead.";
-  intro; apply H; clear H.
-
 (* To contradict an hypothesis without copying its type. *)
 
 Ltac absurd_hyp H :=
@@ -79,7 +73,7 @@ Ltac case_eq x := generalize (eq_refl x); pattern x at -1; case x.
 
 (* use either discriminate or injection on a hypothesis *)
 
-Ltac destr_eq H := discriminate H || (try (injection H; clear H; intro H)).
+Ltac destr_eq H := discriminate H || (try (injection H as H)).
 
 (* Similar variants of destruct *)
 
diff --git a/theories/Init/Tauto.v b/theories/Init/Tauto.v
new file mode 100644
index 00000000..1e409607
--- /dev/null
+++ b/theories/Init/Tauto.v
@@ -0,0 +1,101 @@
+Require Import Notations.
+Require Import Datatypes.
+Require Import Logic.
+
+Local Declare ML Module "tauto".
+
+Local Ltac not_dep_intros :=
+  repeat match goal with
+  | |- (forall (_: ?X1), ?X2) => intro
+  | |- (Coq.Init.Logic.not _) => unfold Coq.Init.Logic.not at 1; intro
+  end.
+
+Local Ltac axioms flags :=
+  match reverse goal with
+    | |- ?X1 => is_unit_or_eq flags X1; constructor 1
+    | _:?X1 |- _ => is_empty flags X1; elimtype X1; assumption
+    | _:?X1 |- ?X1 => assumption
+  end.
+
+Local Ltac simplif flags :=
+  not_dep_intros;
+  repeat
+     (match reverse goal with
+      | id: ?X1 |- _ => is_conj flags X1; elim id; do 2 intro; clear id
+      | id: (Coq.Init.Logic.iff _ _) |- _ => elim id; do 2 intro; clear id
+      | id: (Coq.Init.Logic.not _) |- _ => red in id
+      | id: ?X1 |- _ => is_disj flags X1; elim id; intro; clear id
+      | 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: forall (_ : ?X1), ?X2|- _ =>
+        is_unit_or_eq flags X1; cut X2;
+    [ intro; clear id
+    | (* id : forall (_: ?X1), ?X2 |- ?X2 *)
+      cut X1; [exact id| constructor 1; fail]
+    ]
+      | id: forall (_ : ?X1), ?X2|- _ =>
+        flatten_contravariant_conj flags X1 X2 id
+  (* moved from "id:(?A/\?B)->?X2|-" to "?A->?B->?X2|-" *)
+      | 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: forall (_:?X1), ?X2|- _ =>
+        flatten_contravariant_disj flags X1 X2 id
+  (* moved from "id:(?A\/?B)->?X2|-" to "?A->?X2,?B->?X2|-" *)
+      | |- ?X1 => is_conj flags X1; split
+      | |- (Coq.Init.Logic.iff _ _) => split
+      | |- (Coq.Init.Logic.not _) => red
+      end;
+      not_dep_intros).
+
+Local Ltac tauto_intuit flags t_reduce t_solver :=
+ let rec t_tauto_intuit :=
+ (simplif flags; axioms flags
+ || match reverse goal with
+    | id:forall(_: forall (_: ?X1), ?X2), ?X3|- _ =>
+  cut X3;
+    [ 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 ]]]
+    | 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 =>
+        is_disj flags X1; solve [left;t_tauto_intuit | right;t_tauto_intuit]
+    end
+  ||
+  (* NB: [|- _ -> _] matches any product *)
+  match goal with | |- forall (_ : _),  _ => intro; t_tauto_intuit
+  |  |- _  => t_reduce;t_solver
+  end
+  ||
+  t_solver
+ ) in t_tauto_intuit.
+
+Local Ltac intuition_gen flags solver := tauto_intuit flags reduction_not_iff solver.
+Local Ltac tauto_intuitionistic flags := intuition_gen flags fail || fail "tauto failed".
+Local Ltac tauto_classical flags :=
+  (apply_nnpp || fail "tauto failed"); (tauto_intuitionistic flags || fail "Classical tauto failed").
+Local Ltac tauto_gen flags := tauto_intuitionistic flags || tauto_classical flags.
+
+Ltac tauto := with_uniform_flags ltac:(fun flags => tauto_gen flags).
+Ltac dtauto := with_power_flags ltac:(fun flags => tauto_gen flags).
+
+Ltac intuition := with_uniform_flags ltac:(fun flags => intuition_gen flags ltac:(auto with *)).
+Local Ltac intuition_then tac := with_uniform_flags ltac:(fun flags => intuition_gen flags tac).
+
+Ltac dintuition := with_power_flags ltac:(fun flags => intuition_gen flags ltac:(auto with *)).
+Local Ltac dintuition_then tac := with_power_flags ltac:(fun flags => intuition_gen flags tac).
+
+Tactic Notation "intuition" := intuition.
+Tactic Notation "intuition" tactic(t) := intuition_then t.
+
+Tactic Notation "dintuition" := dintuition.
+Tactic Notation "dintuition" tactic(t) := dintuition_then t.
diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v
index 985ecaf2..b5b17e5e 100644
--- a/theories/Init/Wf.v
+++ b/theories/Init/Wf.v
@@ -34,7 +34,7 @@ Section Well_founded.
   destruct 1; trivial.
  Defined.
 
- Global Implicit Arguments Acc_inv [x y] [x].
+ Global Arguments Acc_inv [x] _ [y] _, [x] _ y _.
 
  (** A relation is well-founded if every element is accessible *)
 
diff --git a/theories/Init/vo.itarget b/theories/Init/vo.itarget
index cc62e66c..99877065 100644
--- a/theories/Init/vo.itarget
+++ b/theories/Init/vo.itarget
@@ -7,4 +7,5 @@ Prelude.vo
 Specif.vo
 Tactics.vo
 Wf.vo
-Nat.vo
\ No newline at end of file
+Nat.vo
+Tauto.vo
diff --git a/theories/Lists/List.v b/theories/Lists/List.v
index cc7586fe..30f1dec2 100644
--- a/theories/Lists/List.v
+++ b/theories/Lists/List.v
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 Require Setoid.
-Require Import PeanoNat Le Gt Minus Bool.
+Require Import PeanoNat Le Gt Minus Bool Lt.
 
 Set Implicit Arguments.
 (* Set Universe Polymorphism. *)
@@ -21,12 +21,13 @@ Set Implicit Arguments.
 
 Open Scope list_scope.
 
-(** Standard notations for lists. 
+(** 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.
+Notation "[ ]" := nil (format "[ ]") : list_scope.
+Notation "[ x ]" := (cons x nil) : list_scope.
+Notation "[ x ; y ; .. ; z ]" :=  (cons x (cons y .. (cons z nil) ..)) : list_scope.
+Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..) (compat "8.4") : list_scope.
 End ListNotations.
 
 Import ListNotations.
@@ -195,7 +196,7 @@ Section Facts.
   Qed.
 
   Theorem app_nil_r : forall l:list A, l ++ [] = l.
-  Proof. 
+  Proof.
     induction l; simpl; f_equal; auto.
   Qed.
 
@@ -248,8 +249,7 @@ Section Facts.
     generalize (app_nil_r l); intros E.
     rewrite -> E; auto.
     intros.
-    injection H.
-    intro.
+    injection H as H H0.
     assert ([] = l ++ a0 :: l0) by auto.
     apply app_cons_not_nil in H1 as [].
   Qed.
@@ -335,16 +335,16 @@ Section Facts.
     absurd (length (x1 :: l1 ++ l) <= length l).
     simpl; rewrite app_length; auto with arith.
     rewrite H; auto with arith.
-    injection H; clear H; intros; f_equal; eauto.
+    injection H as H H0; f_equal; eauto.
   Qed.
 
 End Facts.
 
-Hint Resolve app_assoc app_assoc_reverse: datatypes v62.
-Hint Resolve app_comm_cons app_cons_not_nil: datatypes v62.
-Hint Immediate app_eq_nil: datatypes v62.
-Hint Resolve app_eq_unit app_inj_tail: datatypes v62.
-Hint Resolve in_eq in_cons in_inv in_nil in_app_or in_or_app: datatypes v62.
+Hint Resolve app_assoc app_assoc_reverse: datatypes.
+Hint Resolve app_comm_cons app_cons_not_nil: datatypes.
+Hint Immediate app_eq_nil: datatypes.
+Hint Resolve app_eq_unit app_inj_tail: datatypes.
+Hint Resolve in_eq in_cons in_inv in_nil in_app_or in_or_app: datatypes.
 
 
 
@@ -518,7 +518,7 @@ Section Elts.
   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.
+    - exists nil; exists l. now injection H as ->.
     - destruct (IH _ H) as (l1 & l2 & H1 & H2).
       exists (x::l1); exists l2; simpl; split; now f_equal.
   Qed.
@@ -1385,9 +1385,8 @@ End Fold_Right_Recursor.
     Lemma combine_split : forall (l:list A)(l':list B), length l = length l' ->
       split (combine l l') = (l,l').
     Proof.
-      induction l; destruct l'; simpl; intros; auto; try discriminate.
-      injection H; clear H; intros.
-      rewrite IHl; auto.
+      induction l, l'; simpl; trivial; try discriminate.
+      now intros [= ->%IHl].
     Qed.
 
     Lemma in_combine_l : forall (l:list A)(l':list B)(x:A)(y:B),
@@ -1471,7 +1470,7 @@ End Fold_Right_Recursor.
       destruct (in_app_or _ _ _ H); clear H.
       destruct (in_map_iff (fun y : B => (a, y)) l' (x,y)) as (H1,_).
       destruct (H1 H0) as (z,(H2,H3)); clear H0 H1.
-      injection H2; clear H2; intros; subst; intuition.
+      injection H2 as -> ->; intuition.
       intuition.
     Qed.
 
@@ -1545,7 +1544,7 @@ Section length_order.
 End length_order.
 
 Hint Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons:
-  datatypes v62.
+  datatypes.
 
 
 (******************************)
@@ -1614,7 +1613,7 @@ Section SetIncl.
 End SetIncl.
 
 Hint Resolve incl_refl incl_tl incl_tran incl_appl incl_appr incl_cons
-  incl_app: datatypes v62.
+  incl_app: datatypes.
 
 
 (**************************************)
@@ -1634,6 +1633,80 @@ Section Cutting.
 	       end
     end.
 
+  Lemma firstn_nil n: firstn n [] = [].
+  Proof. induction n; now simpl. Qed.
+
+  Lemma firstn_cons n a l: firstn (S n) (a::l) = a :: (firstn n l).
+  Proof. now simpl. Qed.
+
+  Lemma firstn_all l: firstn (length l) l = l.
+  Proof. induction l as [| ? ? H]; simpl; [reflexivity | now rewrite H]. Qed.
+
+  Lemma firstn_all2 n: forall (l:list A), (length l) <= n -> firstn n l = l.
+  Proof. induction n as [|k iHk].
+    - intro. inversion 1 as [H1|?].
+      rewrite (length_zero_iff_nil l) in H1. subst. now simpl.
+    - destruct l as [|x xs]; simpl.
+      * now reflexivity.
+      * simpl. intro H. apply Peano.le_S_n in H. f_equal. apply iHk, H.
+  Qed.
+
+  Lemma firstn_O l: firstn 0 l = [].
+  Proof. now simpl. Qed.
+
+  Lemma firstn_le_length n: forall l:list A, length (firstn n l) <= n.
+  Proof.
+    induction n as [|k iHk]; simpl; [auto | destruct l as [|x xs]; simpl].
+    - auto with arith.
+    - apply Peano.le_n_S, iHk.
+  Qed.
+
+  Lemma firstn_length_le: forall l:list A, forall n:nat,
+    n <= length l -> length (firstn n l) = n.
+  Proof. induction l as [|x xs Hrec].
+    - simpl. intros n H. apply le_n_0_eq in H. rewrite <- H. now simpl.
+    - destruct n.
+      * now simpl.
+      * simpl. intro H. apply le_S_n in H. now rewrite (Hrec n H).
+  Qed.
+
+  Lemma firstn_app n:
+    forall l1 l2,
+    firstn n (l1 ++ l2) = (firstn n l1) ++ (firstn (n - length l1) l2).
+  Proof. induction n as [|k iHk]; intros l1 l2.
+    - now simpl.
+    - destruct l1 as [|x xs].
+      * unfold firstn at 2, length. now rewrite 2!app_nil_l, <- minus_n_O.
+      * rewrite <- app_comm_cons. simpl. f_equal. apply iHk.
+  Qed.
+
+  Lemma firstn_app_2 n:
+    forall l1 l2,
+    firstn ((length l1) + n) (l1 ++ l2) = l1 ++ firstn n l2.
+  Proof. induction n as [| k iHk];intros l1 l2.
+    - unfold firstn at 2. rewrite <- plus_n_O, app_nil_r.
+      rewrite firstn_app. rewrite <- minus_diag_reverse.
+      unfold firstn at 2. rewrite app_nil_r. apply firstn_all.
+    - destruct l2 as [|x xs].
+      * simpl. rewrite app_nil_r. apply firstn_all2. auto with arith.
+      * rewrite firstn_app. assert (H0 : (length l1 + S k - length l1) = S k).
+        auto with arith.
+        rewrite H0, firstn_all2; [reflexivity | auto with arith].
+  Qed.
+
+  Lemma firstn_firstn:
+    forall l:list A,
+    forall i j : nat,
+    firstn i (firstn j l) = firstn (min i j) l.
+  Proof. induction l as [|x xs Hl].
+    - intros. simpl. now rewrite ?firstn_nil.
+    - destruct i.
+      * intro. now simpl.
+      * destruct j.
+        + now simpl.
+        + simpl. f_equal. apply Hl.
+  Qed.
+
   Fixpoint skipn (n:nat)(l:list A) : list A :=
     match n with
       | 0 => l
@@ -2292,7 +2365,7 @@ Notation rev_acc := rev_append (only parsing).
 Notation rev_acc_rev := rev_append_rev (only parsing).
 Notation AllS := Forall (only parsing). (* was formerly in TheoryList *)
 
-Hint Resolve app_nil_end : datatypes v62.
+Hint Resolve app_nil_end : datatypes.
 (* end hide *)
 
 Section Repeat.
diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v
index fd0464fb..655d3940 100644
--- a/theories/Lists/ListSet.v
+++ b/theories/Lists/ListSet.v
@@ -48,7 +48,11 @@ Section first_definitions.
         end
     end.
 
-  (** If [a] belongs to [x], removes [a] from [x]. If not, does nothing *)
+  (** If [a] belongs to [x], removes [a] from [x]. If not, does nothing.
+      Invariant: any element should occur at most once in [x], see for
+      instance [set_add]. We hence remove here only the first occurrence
+      of [a] in [x]. *)
+
   Fixpoint set_remove (a:A) (x:set) : set :=
     match x with
     | nil => empty_set
@@ -227,6 +231,68 @@ Section first_definitions.
     intros; elim (Aeq_dec a a0); intros; discriminate.
   Qed.
 
+  Lemma set_add_iff a b l : In a (set_add b l) <-> a = b \/ In a l.
+  Proof.
+  split. apply set_add_elim. apply set_add_intro.
+  Qed.
+
+  Lemma set_add_nodup a l : NoDup l -> NoDup (set_add a l).
+  Proof.
+   induction 1 as [|x l H H' IH]; simpl.
+   - constructor; [ tauto | constructor ].
+   - destruct (Aeq_dec a x) as [<-|Hax]; constructor; trivial.
+     rewrite set_add_iff. intuition.
+  Qed.
+
+  Lemma set_remove_1 (a b : A) (l : set) :
+    In a (set_remove b l) -> In a l.
+  Proof.
+    induction l as [|x xs Hrec].
+    - intros. auto.
+    - simpl. destruct (Aeq_dec b x).
+      * tauto.
+      * intro H. destruct H.
+        + rewrite H. apply in_eq.
+      + apply in_cons. apply Hrec. assumption.
+  Qed.
+
+  Lemma set_remove_2 (a b:A) (l : set) :
+    NoDup l -> In a (set_remove b l) -> a <> b.
+  Proof.
+    induction l as [|x l IH]; intro ND; simpl.
+    - tauto.
+    - inversion_clear ND.
+      destruct (Aeq_dec b x) as [<-|Hbx].
+      + congruence.
+      + destruct 1; subst; auto.
+  Qed.
+
+  Lemma set_remove_3 (a b : A) (l : set) :
+    In a l -> a <> b -> In a (set_remove b l).
+  Proof.
+    induction l as [|x xs Hrec].
+    - now simpl.
+    - simpl. destruct (Aeq_dec b x) as [<-|Hbx]; simpl; intuition.
+      congruence.
+  Qed.
+
+  Lemma set_remove_iff (a b : A) (l : set) :
+   NoDup l -> (In a (set_remove b l) <-> In a l /\ a <> b).
+  Proof.
+   split; try split.
+   - eapply set_remove_1; eauto.
+   - eapply set_remove_2; eauto.
+   - destruct 1; apply set_remove_3; auto.
+  Qed.
+
+  Lemma set_remove_nodup a l : NoDup l -> NoDup (set_remove a l).
+  Proof.
+   induction 1 as [|x l H H' IH]; simpl.
+   - constructor.
+   - destruct (Aeq_dec a x) as [<-|Hax]; trivial.
+     constructor; trivial.
+     rewrite set_remove_iff; trivial. intuition.
+  Qed.
 
   Lemma set_union_intro1 :
    forall (a:A) (x y:set), set_In a x -> set_In a (set_union x y).
@@ -264,18 +330,26 @@ Section first_definitions.
     tauto.
   Qed.
 
+  Lemma set_union_iff a l l': In a (set_union l l') <-> In a l \/ In a l'.
+  Proof.
+    split. apply set_union_elim. apply set_union_intro.
+  Qed.
+
+  Lemma set_union_nodup l l' : NoDup l -> NoDup l' -> NoDup (set_union l l').
+  Proof.
+   induction 2 as [|x' l' ? ? IH]; simpl; trivial. now apply set_add_nodup.
+  Qed.
+
   Lemma set_union_emptyL :
    forall (a:A) (x:set), set_In a (set_union empty_set x) -> set_In a x.
     intros a x H; case (set_union_elim _ _ _ H); auto || contradiction.
   Qed.
 
-
   Lemma set_union_emptyR :
    forall (a:A) (x:set), set_In a (set_union x empty_set) -> set_In a x.
     intros a x H; case (set_union_elim _ _ _ H); auto || contradiction.
   Qed.
 
-
   Lemma set_inter_intro :
    forall (a:A) (x y:set),
      set_In a x -> set_In a y -> set_In a (set_inter x y).
@@ -326,6 +400,21 @@ Section first_definitions.
     eauto with datatypes.
   Qed.
 
+  Lemma set_inter_iff a l l' : In a (set_inter l l') <-> In a l /\ In a l'.
+  Proof.
+    split.
+    - apply set_inter_elim.
+    - destruct 1. now apply set_inter_intro.
+  Qed.
+
+  Lemma set_inter_nodup l l' : NoDup l -> NoDup l' -> NoDup (set_inter l l').
+  Proof.
+   induction 1 as [|x l H H' IH]; intro Hl'; simpl.
+   - constructor.
+   - destruct (set_mem x l'); auto.
+     constructor; auto. rewrite set_inter_iff; tauto.
+  Qed.
+
   Lemma set_diff_intro :
    forall (a:A) (x y:set),
      set_In a x -> ~ set_In a y -> set_In a (set_diff x y).
@@ -360,6 +449,20 @@ Section first_definitions.
   rewrite H; trivial.
   Qed.
 
+  Lemma set_diff_iff a l l' : In a (set_diff l l') <-> In a l /\ ~In a l'.
+  Proof.
+  split.
+  - split; [eapply set_diff_elim1 | eapply set_diff_elim2]; eauto.
+  - destruct 1. now apply set_diff_intro.
+  Qed.
+
+  Lemma set_diff_nodup l l' : NoDup l -> NoDup l' -> NoDup (set_diff l l').
+  Proof.
+   induction 1 as [|x l H H' IH]; intro Hl'; simpl.
+   - constructor.
+   - destruct (set_mem x l'); auto using set_add_nodup.
+  Qed.
+
   Lemma set_diff_trivial : forall (a:A) (x:set), ~ set_In a (set_diff x x).
   red; intros a x H.
   apply (set_diff_elim2 _ _ _ H).
diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v
index 7ec3d250..1c302b22 100644
--- a/theories/Lists/Streams.v
+++ b/theories/Lists/Streams.v
@@ -51,7 +51,7 @@ Lemma tl_nth_tl :
 Proof.
   simple induction n; simpl; auto.
 Qed.
-Hint Resolve tl_nth_tl: datatypes v62.
+Hint Resolve tl_nth_tl: datatypes.
 
 Lemma Str_nth_tl_plus :
  forall (n m:nat) (s:Stream),
diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v
index c947062a..afd64efd 100644
--- a/theories/Logic/ClassicalFacts.v
+++ b/theories/Logic/ClassicalFacts.v
@@ -34,6 +34,8 @@ Table of contents:
 
 3 3. Independence of general premises and drinker's paradox
 
+4. Classical logic and principle of unrestricted minimization
+
 *)
 
 (************************************************************************)
@@ -658,3 +660,79 @@ Proof.
     exists x; intro; exact Hx.
     exists x0; exact Hnot.
 Qed.
+
+(** ** Principle of unrestricted minimization *)
+
+Require Import Coq.Arith.PeanoNat.
+
+Definition Minimal (P:nat -> Prop) (n:nat) : Prop :=
+  P n /\ forall k, P k -> n<=k.
+
+Definition Minimization_Property (P : nat -> Prop) : Prop :=
+  forall n, P n -> exists m, Minimal P m.
+
+Section Unrestricted_minimization_entails_excluded_middle.
+
+  Hypothesis unrestricted_minimization: forall P, Minimization_Property P.
+
+  Theorem unrestricted_minimization_entails_excluded_middle : forall A, A\/~A.
+  Proof.
+    intros A.
+    pose (P := fun n:nat => n=0/\A \/ n=1).
+    assert (P 1) as h.
+    { unfold P. intuition. }
+    assert (P 0 <-> A) as p₀.
+    { split.
+      + intros [[_ h₀]|[=]]. assumption.
+      + unfold P. tauto. }
+    apply unrestricted_minimization in h as ([|[|m]] & hm & hmm).
+    + intuition.
+    + right.
+      intros HA. apply p₀, hmm, PeanoNat.Nat.nle_succ_0 in HA. assumption.
+    + destruct hm as [([=],_) | [=] ].
+  Qed.
+
+End Unrestricted_minimization_entails_excluded_middle.
+
+Require Import Wf_nat.
+
+Section Excluded_middle_entails_unrestricted_minimization.
+
+  Hypothesis em : forall A, A\/~A.
+
+  Theorem excluded_middle_entails_unrestricted_minimization : 
+    forall P, Minimization_Property P.
+  Proof.
+    intros P n HPn.
+    assert (dec : forall n, P n \/ ~ P n) by auto using em.
+    assert (ex : exists n, P n) by (exists n; assumption).
+    destruct (dec_inh_nat_subset_has_unique_least_element P dec ex) as (n' & HPn' & _).
+    exists n'. assumption.
+  Qed.
+
+End Excluded_middle_entails_unrestricted_minimization.
+
+(** However, minimization for a given predicate does not necessarily imply
+    decidability of this predicate *)
+
+Section Example_of_undecidable_predicate_with_the_minimization_property.
+
+  Variable s : nat -> bool.
+
+  Let P n := exists k, n<=k /\ s k = true.
+
+  Example undecidable_predicate_with_the_minimization_property : 
+    Minimization_Property P.
+  Proof.
+    unfold Minimization_Property.
+    intros h hn.
+    exists 0. split.
+    + unfold P in *. destruct hn as (k&hk₁&hk₂).
+      exists k. split.
+      * rewrite <- hk₁.
+        apply PeanoNat.Nat.le_0_l.
+      * assumption.
+    + intros **. apply PeanoNat.Nat.le_0_l.
+  Qed.
+
+End Example_of_undecidable_predicate_with_the_minimization_property.
diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v
index 2ba7253c..8b6054f9 100644
--- a/theories/Logic/Decidable.v
+++ b/theories/Logic/Decidable.v
@@ -50,7 +50,7 @@ Qed.
 Theorem dec_iff :
  forall A B:Prop, decidable A -> decidable B -> decidable (A<->B).
 Proof.
-unfold decidable; tauto.
+unfold decidable. tauto.
 Qed.
 
 Theorem not_not : forall P:Prop, decidable P -> ~ ~ P -> P.
diff --git a/theories/Logic/Eqdep.v b/theories/Logic/Eqdep.v
index f3a2783e..5ef86b8e 100644
--- a/theories/Logic/Eqdep.v
+++ b/theories/Logic/Eqdep.v
@@ -33,5 +33,5 @@ Export EqdepTheory.
 
 (** Exported hints *)
 
-Hint Resolve eq_dep_eq: eqdep v62.
+Hint Resolve eq_dep_eq: eqdep.
 Hint Resolve inj_pair2 inj_pairT2: eqdep.
diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v
index 30e26c7c..bd59159b 100644
--- a/theories/Logic/EqdepFacts.v
+++ b/theories/Logic/EqdepFacts.v
@@ -164,7 +164,7 @@ Proof.
   split; auto using eq_sig_eq_dep, eq_dep_eq_sig.
 Qed.
 
-(** Dependent equality is equivalent tco a dependent pair of equalities *)
+(** Dependent equality is equivalent to a dependent pair of equalities *)
 
 Set Implicit Arguments.
 
diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v
index 8ded7476..841f843c 100644
--- a/theories/Logic/Hurkens.v
+++ b/theories/Logic/Hurkens.v
@@ -631,6 +631,8 @@ End NoRetractFromTypeToProp.
 
 Module TypeNeqSmallType.
 
+Unset Universe Polymorphism.
+
 Section Paradox.
 
 (** ** Universe [U] is equal to one of its elements. *)
@@ -655,7 +657,6 @@ Proof.
   reflexivity.
 Qed.
 
-
 Theorem paradox : False.
 Proof.
   Generic.paradox p.
diff --git a/theories/Logic/PropFacts.v b/theories/Logic/PropFacts.v
new file mode 100644
index 00000000..309539e5
--- /dev/null
+++ b/theories/Logic/PropFacts.v
@@ -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        *)
+(************************************************************************)
+
+(** * Basic facts about Prop as a type *)
+
+(** An intuitionistic theorem from topos theory [[LambekScott]]
+
+References:
+
+[[LambekScott]] Jim Lambek, Phil J. Scott, Introduction to higher
+order categorical logic, Cambridge Studies in Advanced Mathematics
+(Book 7), 1988.
+
+*)
+
+Theorem injection_is_involution_in_Prop
+  (f : Prop -> Prop)
+  (inj : forall A B, (f A <-> f B) -> (A <-> B))
+  (ext : forall A B, A <-> B -> f A <-> f B)
+  : forall A, f (f A) <-> A.
+Proof.
+intros.
+enough (f (f (f A)) <-> f A) by (apply inj; assumption).
+split; intro H.
+- now_show (f A).
+  enough (f A <-> True) by firstorder.
+  enough (f (f A) <-> f True) by (apply inj; assumption).
+  split; intro H'.
+  + now_show (f True).
+    enough (f (f (f A)) <-> f True) by firstorder.
+    apply ext; firstorder.
+  + now_show (f (f A)).
+    enough (f (f A) <-> True) by firstorder.
+    apply inj; firstorder.
+- now_show (f (f (f A))).
+  enough (f A <-> f (f (f A))) by firstorder.
+  apply ext.
+  split; intro H'.
+  + now_show (f (f A)).
+    enough (f A <-> f (f A)) by firstorder.
+    apply ext; firstorder.
+  + now_show A.
+    enough (f A <-> A) by firstorder.
+    apply inj; firstorder.
+Defined.
diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v
index cc023cc3..a3c265a2 100644
--- a/theories/MSets/MSetAVL.v
+++ b/theories/MSets/MSetAVL.v
@@ -417,6 +417,7 @@ Local Open Scope Int_scope.
     Let's do its job by hand: *)
 
 Ltac join_tac :=
+ let l := fresh "l" in
  intro l; induction l as [| lh ll _ lx lr Hlr];
    [ | intros x r; induction r as [| rh rl Hrl rx rr _]; unfold join;
      [ | destruct ((rh+2) <? lh) eqn:LT;
diff --git a/theories/MSets/MSetDecide.v b/theories/MSets/MSetDecide.v
index f2555791..9c622fd7 100644
--- a/theories/MSets/MSetDecide.v
+++ b/theories/MSets/MSetDecide.v
@@ -357,17 +357,8 @@ the above form:
         | _ => idtac
       end.
 
-    (** [if t then t1 else t2] executes [t] and, if it does not
-        fail, then [t1] will be applied to all subgoals
-        produced.  If [t] fails, then [t2] is executed. *)
-    Tactic Notation
-      "if" tactic(t)
-      "then" tactic(t1)
-      "else" tactic(t2) :=
-      first [ t; first [ t1 | fail 2 ] | t2 ].
-
     Ltac abstract_term t :=
-      if (is_var t) then fail "no need to abstract a variable"
+      tryif (is_var t) then fail "no need to abstract a variable"
       else (let x := fresh "x" in set (x := t) in *; try clearbody x).
 
     Ltac abstract_elements :=
@@ -478,11 +469,11 @@ the above form:
       repeat (
         match goal with
         | H : context [ @Logic.eq ?T ?x ?y ] |- _ =>
-          if (change T with E.t in H) then fail
-          else if (change T with t in H) then fail
+          tryif (change T with E.t in H) then fail
+          else tryif (change T with t in H) then fail
           else clear H
         | H : ?P |- _ =>
-          if prop (MSet_Prop P) holds by
+          tryif prop (MSet_Prop P) holds by
             (auto 100 with MSet_Prop)
           then fail
           else clear H
@@ -747,7 +738,7 @@ the above form:
     | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False =>
       contradict H; fsetdec_body
     | H: ?P -> False |- ?Q -> False =>
-      if prop (MSet_elt_Prop P) holds by
+      tryif prop (MSet_elt_Prop P) holds by
         (auto 100 with MSet_Prop)
       then (contradict H; fsetdec_body)
       else fsetdec_body
diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v
index bd881168..74a7f6df 100644
--- a/theories/MSets/MSetInterface.v
+++ b/theories/MSets/MSetInterface.v
@@ -345,6 +345,9 @@ Module Type WRawSets (E : DecidableType).
       predicate [Ok]. If [Ok] isn't decidable, [isok] may be the
       always-false function. *)
   Parameter isok : t -> bool.
+  (** MS: 
+    Dangerous instance, the [isok s = true] hypothesis cannot be discharged
+   with typeclass resolution. Is it really an instance? *)
   Declare Instance isok_Ok s `(isok s = true) : Ok s | 10.
 
   (** Logical predicates *)
diff --git a/theories/MSets/MSetList.v b/theories/MSets/MSetList.v
index fb0d1ad9..05c20eb8 100644
--- a/theories/MSets/MSetList.v
+++ b/theories/MSets/MSetList.v
@@ -8,7 +8,7 @@
 
 (** * Finite sets library *)
 
-(** This file proposes an implementation of the non-dependant
+(** This file proposes an implementation of the non-dependent
     interface [MSetInterface.S] using strictly ordered list. *)
 
 Require Export MSetInterface OrdersFacts OrdersLists.
diff --git a/theories/MSets/MSetPositive.v b/theories/MSets/MSetPositive.v
index 8dd240f4..be95a037 100644
--- a/theories/MSets/MSetPositive.v
+++ b/theories/MSets/MSetPositive.v
@@ -908,10 +908,10 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
       destruct o.
         intros x H. injection H; intros; subst. reflexivity.
         revert IHl. case choose.
-          intros p Hp x H. injection H; intros; subst; clear H. apply Hp.
+          intros p Hp x H. injection H as <-. apply Hp.
            reflexivity.
           intros _ x. revert IHr. case choose.
-            intros p Hp H. injection H; intros; subst; clear H. apply Hp.
+            intros p Hp H. injection H as <-. apply Hp.
             reflexivity.
             intros. discriminate.
   Qed.
@@ -968,11 +968,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
    induction s as [| l IHl o r IHr]; simpl.
      intros. discriminate.
      intros x. destruct (min_elt l); intros.
-       injection H. intros <-. apply IHl. reflexivity.
+       injection H as <-. apply IHl. reflexivity.
        destruct o; simpl.
-         injection H. intros <-. reflexivity.
+         injection H as <-. reflexivity.
          destruct (min_elt r); simpl in *.
-           injection H. intros <-. apply IHr. reflexivity.
+           injection H as <-. apply IHr. reflexivity.
            discriminate.
   Qed.
 
@@ -996,15 +996,15 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
     induction s as [|l IHl o r IHr]; intros x y H H'.
       discriminate.
       simpl in H. case_eq (min_elt l).
-        intros p Hp. rewrite Hp in H. injection H; intros <-.
+        intros p Hp. rewrite Hp in H. injection H as <-.
         destruct y as [z|z|]; simpl; intro; trivial. apply (IHl p z); trivial.
         intro Hp; rewrite Hp in H. apply min_elt_spec3 in Hp.
         destruct o.
-          injection H. intros <- Hl. clear H.
+          injection H as <-. intros Hl.
           destruct y as [z|z|]; simpl; trivial. elim (Hp _ H').
 
           destruct (min_elt r).
-            injection H. intros <-. clear H.
+            injection H as <-.
             destruct y as [z|z|].
               apply (IHr e z); trivial.
               elim (Hp _ H').
@@ -1021,11 +1021,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
    induction s as [| l IHl o r IHr]; simpl.
      intros. discriminate.
      intros x. destruct (max_elt r); intros.
-       injection H. intros <-. apply IHr. reflexivity.
+       injection H as <-. apply IHr. reflexivity.
        destruct o; simpl.
-         injection H. intros <-. reflexivity.
+         injection H as <-. reflexivity.
          destruct (max_elt l); simpl in *.
-           injection H. intros <-. apply IHl. reflexivity.
+           injection H as <-. apply IHl. reflexivity.
            discriminate.
   Qed.
 
@@ -1049,15 +1049,15 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
     induction s as [|l IHl o r IHr]; intros x y H H'.
       discriminate.
       simpl in H. case_eq (max_elt r).
-        intros p Hp. rewrite Hp in H. injection H; intros <-.
+        intros p Hp. rewrite Hp in H. injection H as <-.
         destruct y as [z|z|]; simpl; intro; trivial. apply (IHr p z); trivial.
         intro Hp; rewrite Hp in H. apply max_elt_spec3 in Hp.
         destruct o.
-          injection H. intros <- Hl. clear H.
+          injection H as <-. intros Hl.
           destruct y as [z|z|]; simpl; trivial. elim (Hp _ H').
 
           destruct (max_elt l).
-            injection H. intros <-. clear H.
+            injection H as <-.
             destruct y as [z|z|].
               elim (Hp _ H').
               apply (IHl e z); trivial.
diff --git a/theories/MSets/MSetRBT.v b/theories/MSets/MSetRBT.v
index 751d4f35..83a2343d 100644
--- a/theories/MSets/MSetRBT.v
+++ b/theories/MSets/MSetRBT.v
@@ -911,7 +911,7 @@ Proof.
      { inversion_clear O.
        assert (InT x l) by now apply min_elt_spec1. auto. }
      simpl. case X.compare_spec; try order.
-     destruct lc; injection E; clear E; intros; subst l s0; auto.
+     destruct lc; injection E; subst l s0; auto.
 Qed.
 
 Lemma remove_min_spec1 s x s' `{Ok s}:
@@ -1948,7 +1948,7 @@ Module Make (X: Orders.OrderedType) <:
  generalize (fun x s' => @Raw.remove_min_spec1 s x s' Hs).
  set (P := Raw.remove_min_ok s). clearbody P.
  destruct (Raw.remove_min s) as [(x0,s0)|]; try easy.
- intros H U. injection U. clear U; intros; subst. simpl.
+ intros H U. injection U as -> <-. simpl.
  destruct (H x s0); auto. subst; intuition.
  Qed.
 
diff --git a/theories/MSets/MSetWeakList.v b/theories/MSets/MSetWeakList.v
index 372acd56..2ac57a93 100644
--- a/theories/MSets/MSetWeakList.v
+++ b/theories/MSets/MSetWeakList.v
@@ -8,7 +8,7 @@
 
 (** * Finite sets library *)
 
-(** This file proposes an implementation of the non-dependant
+(** This file proposes an implementation of the non-dependent
     interface [MSetWeakInterface.S] using lists without redundancy. *)
 
 Require Import MSetInterface.
diff --git a/theories/Numbers/BigNumPrelude.v b/theories/Numbers/BigNumPrelude.v
index 45a7527c..bd893087 100644
--- a/theories/Numbers/BigNumPrelude.v
+++ b/theories/Numbers/BigNumPrelude.v
@@ -10,7 +10,7 @@
 
 (** * BigNumPrelude *)
 
-(** Auxillary functions & theorems used for arbitrary precision efficient
+(** Auxiliary functions & theorems used for arbitrary precision efficient
     numbers. *)
 
 
@@ -22,7 +22,7 @@ Require Export Zpow_facts.
 Declare ML Module "numbers_syntax_plugin".
 
 (* *** Nota Bene ***
-   All results that were general enough has been moved in ZArith.
+   All results that were general enough have been moved in ZArith.
    Only remain here specialized lemmas and compatibility elements.
    (P.L. 5/11/2007).
 *)
diff --git a/theories/Numbers/Cyclic/Int31/Ring31.v b/theories/Numbers/Cyclic/Int31/Ring31.v
index 215b8bd5..d160f5f1 100644
--- a/theories/Numbers/Cyclic/Int31/Ring31.v
+++ b/theories/Numbers/Cyclic/Int31/Ring31.v
@@ -19,13 +19,13 @@ Local Open Scope list_scope.
 
 Ltac isInt31cst_lst l :=
  match l with
- | nil => constr:true
+ | nil => constr:(true)
  | ?t::?l => match t with
                | D1 => isInt31cst_lst l
                | D0 => isInt31cst_lst l
-               | _ => constr:false
+               | _ => constr:(false)
              end
- | _ => constr:false
+ | _ => constr:(false)
  end.
 
 Ltac isInt31cst t :=
@@ -38,17 +38,17 @@ Ltac isInt31cst t :=
       ::i11::i12::i13::i14::i15::i16::i17::i18::i19::i20
       ::i21::i22::i23::i24::i25::i26::i27::i28::i29::i30::nil)
     in isInt31cst_lst l
- | Int31.On => constr:true
- | Int31.In => constr:true
- | Int31.Tn => constr:true
- | Int31.Twon => constr:true
- | _ => constr:false
+ | Int31.On => constr:(true)
+ | Int31.In => constr:(true)
+ | Int31.Tn => constr:(true)
+ | Int31.Twon => constr:(true)
+ | _ => constr:(false)
  end.
 
 Ltac Int31cst t :=
  match isInt31cst t with
- | true => constr:t
- | false => constr:NotConstant
+ | true => constr:(t)
+ | false => constr:(NotConstant)
  end.
 
 (** The generic ring structure inferred from the Cyclic structure *)
diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v
index c115a831..04fc5a8d 100644
--- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v
+++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v
@@ -369,7 +369,7 @@ Section ZModulo.
  assert (Z.div_eucl ([|x|]*[|y|]) wB = (([|x|]*[|y|])/wB,([|x|]*[|y|]) mod wB)).
   unfold Z.modulo, Z.div; destruct Z.div_eucl; auto.
  generalize (Z_div_mod ([|x|]*[|y|]) wB wB_pos); destruct Z.div_eucl as (h,l).
- destruct 1; injection H; clear H; intros.
+ destruct 1; injection H as ? ?.
  rewrite H0.
  assert ([|l|] = l).
   apply Zmod_small; auto.
@@ -411,7 +411,7 @@ Section ZModulo.
   unfold Z.modulo, Z.div; destruct Z.div_eucl; auto.
  generalize (Z_div_mod [|a|] [|b|] H0).
  destruct Z.div_eucl as (q,r); destruct 1; intros.
- injection H1; clear H1; intros.
+ injection H1 as ? ?.
  assert ([|r|]=r).
   apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|];
    auto with zarith.
@@ -522,7 +522,7 @@ Section ZModulo.
   unfold Z.modulo, Z.div; destruct Z.div_eucl; auto.
  generalize (Z_div_mod a [|b|] H3).
  destruct Z.div_eucl as (q,r); destruct 1; intros.
- injection H4; clear H4; intros.
+ injection H4 as ? ?.
  assert ([|r|]=r).
   apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|];
    auto with zarith.
diff --git a/theories/Numbers/Integer/Abstract/ZDivEucl.v b/theories/Numbers/Integer/Abstract/ZDivEucl.v
index 278e1bcf..c2fa69e5 100644
--- a/theories/Numbers/Integer/Abstract/ZDivEucl.v
+++ b/theories/Numbers/Integer/Abstract/ZDivEucl.v
@@ -30,18 +30,23 @@ Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv.
     We just ignore them here.
 *)
 
-Module Type EuclidSpec (Import A : ZAxiomsSig')(Import B : DivMod' A).
- Axiom mod_always_pos : forall a b, b ~= 0 -> 0 <= a mod b < abs b.
+Module Type EuclidSpec (Import A : ZAxiomsSig')(Import B : DivMod A).
+ Axiom mod_always_pos : forall a b, b ~= 0 -> 0 <= B.modulo a b < abs b.
 End EuclidSpec.
 
 Module Type ZEuclid (Z:ZAxiomsSig) := NZDiv.NZDiv Z <+ EuclidSpec Z.
-Module Type ZEuclid' (Z:ZAxiomsSig) := NZDiv.NZDiv' Z <+ EuclidSpec Z.
 
 Module ZEuclidProp
  (Import A : ZAxiomsSig')
  (Import B : ZMulOrderProp A)
  (Import C : ZSgnAbsProp A B)
- (Import D : ZEuclid' A).
+ (Import D : ZEuclid A).
+
+ (** We put notations in a scope, to avoid warnings about
+     redefinitions of notations *)
+ Infix "/" := D.div : euclid.
+ Infix "mod" := D.modulo : euclid.
+ Local Open Scope euclid.
 
  Module Import Private_NZDiv := Nop <+ NZDivProp A D B.
 
@@ -615,4 +620,3 @@ intros (c,Hc). rewrite Hc. now apply mod_mul.
 Qed.
 
 End ZEuclidProp.
-
diff --git a/theories/Numbers/Integer/BigZ/BigZ.v b/theories/Numbers/Integer/BigZ/BigZ.v
index ec495d09..7c76011f 100644
--- a/theories/Numbers/Integer/BigZ/BigZ.v
+++ b/theories/Numbers/Integer/BigZ/BigZ.v
@@ -138,7 +138,7 @@ intros NEQ.
 generalize (BigZ.spec_div_eucl a b).
 generalize (Z_div_mod_full [a] [b] NEQ).
 destruct BigZ.div_eucl as (q,r), Z.div_eucl as (q',r').
-intros (EQ,_). injection 1. intros EQr EQq.
+intros (EQ,_). injection 1 as EQr EQq.
 BigZ.zify. rewrite EQr, EQq; auto.
 Qed.
 
@@ -148,26 +148,26 @@ Ltac isBigZcst t :=
  match t with
  | BigZ.Pos ?t => isBigNcst t
  | BigZ.Neg ?t => isBigNcst t
- | BigZ.zero => constr:true
- | BigZ.one => constr:true
- | BigZ.two => constr:true
- | BigZ.minus_one => constr:true
- | _ => constr:false
+ | BigZ.zero => constr:(true)
+ | BigZ.one => constr:(true)
+ | BigZ.two => constr:(true)
+ | BigZ.minus_one => constr:(true)
+ | _ => constr:(false)
  end.
 
 Ltac BigZcst t :=
  match isBigZcst t with
- | true => constr:t
- | false => constr:NotConstant
+ | true => constr:(t)
+ | false => constr:(NotConstant)
  end.
 
 Ltac BigZ_to_N t :=
  match t with
  | BigZ.Pos ?t => BigN_to_N t
- | BigZ.zero => constr:0%N
- | BigZ.one => constr:1%N
- | BigZ.two => constr:2%N
- | _ => constr:NotConstant
+ | BigZ.zero => constr:(0%N)
+ | BigZ.one => constr:(1%N)
+ | BigZ.two => constr:(2%N)
+ | _ => constr:(NotConstant)
  end.
 
 (** Registration for the "ring" tactic *)
diff --git a/theories/Numbers/Integer/BigZ/ZMake.v b/theories/Numbers/Integer/BigZ/ZMake.v
index 8673b8a5..fec6e068 100644
--- a/theories/Numbers/Integer/BigZ/ZMake.v
+++ b/theories/Numbers/Integer/BigZ/ZMake.v
@@ -147,7 +147,7 @@ Module Make (NN:NType) <: ZType.
  Proof.
  apply Bool.eq_iff_eq_true.
  rewrite Z.leb_le. unfold Z.le, leb. rewrite spec_compare.
- destruct Z.compare; split; try easy. now destruct 1.
+ now destruct Z.compare; split.
  Qed.
 
  Definition min n m := match compare n m with Gt => m | _ => n end.
@@ -427,13 +427,13 @@ Module Make (NN:NType) <: ZType.
  (* Pos Neg *)
  generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y) as (q,r).
  break_nonneg x px EQx; break_nonneg y py EQy;
- try (injection 1; intros Hr Hq; rewrite NN.spec_eqb, NN.spec_0, Hr;
+ try (injection 1 as Hq Hr; rewrite NN.spec_eqb, NN.spec_0, Hr;
       simpl; rewrite Hq, NN.spec_0; auto).
  change (- Zpos py) with (Zneg py).
  assert (GT : Zpos py > 0) by (compute; auto).
  generalize (Z_div_mod (Zpos px) (Zpos py) GT).
  unfold Z.div_eucl. destruct (Z.pos_div_eucl px (Zpos py)) as (q',r').
- intros (EQ,MOD). injection 1. intros Hr' Hq'.
+ intros (EQ,MOD). injection 1 as Hq' Hr'.
  rewrite NN.spec_eqb, NN.spec_0, Hr'.
  break_nonneg r pr EQr.
  subst; simpl. rewrite NN.spec_0; auto.
@@ -442,13 +442,13 @@ Module Make (NN:NType) <: ZType.
  (* Neg Pos *)
  generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y) as (q,r).
  break_nonneg x px EQx; break_nonneg y py EQy;
- try (injection 1; intros Hr Hq; rewrite NN.spec_eqb, NN.spec_0, Hr;
+ try (injection 1 as Hq Hr; rewrite NN.spec_eqb, NN.spec_0, Hr;
       simpl; rewrite Hq, NN.spec_0; auto).
  change (- Zpos px) with (Zneg px).
  assert (GT : Zpos py > 0) by (compute; auto).
  generalize (Z_div_mod (Zpos px) (Zpos py) GT).
  unfold Z.div_eucl. destruct (Z.pos_div_eucl px (Zpos py)) as (q',r').
- intros (EQ,MOD). injection 1. intros Hr' Hq'.
+ intros (EQ,MOD). injection 1 as Hq' Hr'.
  rewrite NN.spec_eqb, NN.spec_0, Hr'.
  break_nonneg r pr EQr.
  subst; simpl. rewrite NN.spec_0; auto.
@@ -457,7 +457,7 @@ Module Make (NN:NType) <: ZType.
  (* Neg Neg *)
  generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y) as (q,r).
  break_nonneg x px EQx; break_nonneg y py EQy;
- try (injection 1; intros Hr Hq; rewrite Hr, Hq; auto).
+ try (injection 1 as -> ->; auto).
  simpl. intros <-; auto.
  Qed.
 
diff --git a/theories/Numbers/NatInt/NZGcd.v b/theories/Numbers/NatInt/NZGcd.v
index 1d367294..44088f8c 100644
--- a/theories/Numbers/NatInt/NZGcd.v
+++ b/theories/Numbers/NatInt/NZGcd.v
@@ -60,8 +60,6 @@ Proof.
  intros n. exists 0. now nzsimpl.
 Qed.
 
-Hint Rewrite divide_1_l divide_0_r : nz.
-
 Lemma divide_0_l : forall n, (0 | n) -> n==0.
 Proof.
  intros n (m,Hm). revert Hm. now nzsimpl.
diff --git a/theories/Numbers/Natural/BigN/BigN.v b/theories/Numbers/Natural/BigN/BigN.v
index 29a1145e..e8ff516f 100644
--- a/theories/Numbers/Natural/BigN/BigN.v
+++ b/theories/Numbers/Natural/BigN/BigN.v
@@ -110,7 +110,7 @@ intros NEQ.
 generalize (BigN.spec_div_eucl a b).
 generalize (Z_div_mod_full [a] [b] NEQ).
 destruct BigN.div_eucl as (q,r), Z.div_eucl as (q',r').
-intros (EQ,_). injection 1. intros EQr EQq.
+intros (EQ,_). injection 1 as EQr EQq.
 BigN.zify. rewrite EQr, EQq; auto.
 Qed.
 
@@ -119,10 +119,10 @@ Qed.
 
 Ltac isStaticWordCst t :=
  match t with
- | W0 => constr:true
+ | W0 => constr:(true)
  | WW ?t1 ?t2 =>
    match isStaticWordCst t1 with
-   | false => constr:false
+   | false => constr:(false)
    | true => isStaticWordCst t2
    end
  | _ => isInt31cst t
@@ -139,30 +139,30 @@ Ltac isBigNcst t :=
  | BigN.N6 ?t => isStaticWordCst t
  | BigN.Nn ?n ?t => match isnatcst n with
    | true => isStaticWordCst t
-   | false => constr:false
+   | false => constr:(false)
    end
- | BigN.zero => constr:true
- | BigN.one => constr:true
- | BigN.two => constr:true
- | _ => constr:false
+ | BigN.zero => constr:(true)
+ | BigN.one => constr:(true)
+ | BigN.two => constr:(true)
+ | _ => constr:(false)
  end.
 
 Ltac BigNcst t :=
  match isBigNcst t with
- | true => constr:t
- | false => constr:NotConstant
+ | true => constr:(t)
+ | false => constr:(NotConstant)
  end.
 
 Ltac BigN_to_N t :=
  match isBigNcst t with
  | true => eval vm_compute in (BigN.to_N t)
- | false => constr:NotConstant
+ | false => constr:(NotConstant)
  end.
 
 Ltac Ncst t :=
  match isNcst t with
- | true => constr:t
- | false => constr:NotConstant
+ | true => constr:(t)
+ | false => constr:(NotConstant)
  end.
 
 (** Registration for the "ring" tactic *)
diff --git a/theories/Numbers/Natural/BigN/NMake.v b/theories/Numbers/Natural/BigN/NMake.v
index 98949736..1425041a 100644
--- a/theories/Numbers/Natural/BigN/NMake.v
+++ b/theories/Numbers/Natural/BigN/NMake.v
@@ -338,7 +338,7 @@ Module Make (W0:CyclicType) <: NType.
  Proof.
  apply eq_iff_eq_true.
  rewrite Z.leb_le. unfold Z.le, leb. rewrite spec_compare.
- destruct Z.compare; split; try easy. now destruct 1.
+ now destruct Z.compare; split.
  Qed.
 
  Definition min (n m : t) : t := match compare n m with Gt => m | _ => n end.
diff --git a/theories/Numbers/Natural/BigN/NMake_gen.ml b/theories/Numbers/Natural/BigN/NMake_gen.ml
index 601fa108..5177fae6 100644
--- a/theories/Numbers/Natural/BigN/NMake_gen.ml
+++ b/theories/Numbers/Natural/BigN/NMake_gen.ml
@@ -147,7 +147,7 @@ pr
   pr " Local Notation Size := (SizePlus O).";
   pr "";
 
-  pr " Tactic Notation \"do_size\" tactic(t) := do %i t." (size+1);
+  pr " Tactic Notation (at level 3) \"do_size\" tactic3(t) := do %i t." (size+1);
   pr "";
 
   pr " Definition dom_t n := match n with";
diff --git a/theories/Numbers/Natural/Peano/NPeano.v b/theories/Numbers/Natural/Peano/NPeano.v
index 58b1b018..d0168bd9 100644
--- a/theories/Numbers/Natural/Peano/NPeano.v
+++ b/theories/Numbers/Natural/Peano/NPeano.v
@@ -8,8 +8,88 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-Require Import PeanoNat NAxioms.
+Require Import PeanoNat Even NAxioms.
 
-(** * [PeanoNat.Nat] already implements [NAxiomSig] *)
+(** This file is DEPRECATED ! Use [PeanoNat] (or [Arith]) instead. *)
+
+(** [PeanoNat.Nat] already implements [NAxiomSig] *)
 
 Module Nat <: NAxiomsSig := Nat.
+
+(** Compat notations for stuff that used to be at the beginning of NPeano. *)
+
+Notation leb := Nat.leb (compat "8.4").
+Notation ltb := Nat.ltb (compat "8.4").
+Notation leb_le := Nat.leb_le (compat "8.4").
+Notation ltb_lt := Nat.ltb_lt (compat "8.4").
+Notation pow := Nat.pow (compat "8.4").
+Notation pow_0_r := Nat.pow_0_r (compat "8.4").
+Notation pow_succ_r := Nat.pow_succ_r (compat "8.4").
+Notation square := Nat.square (compat "8.4").
+Notation square_spec := Nat.square_spec (compat "8.4").
+Notation Even := Nat.Even (compat "8.4").
+Notation Odd := Nat.Odd (compat "8.4").
+Notation even := Nat.even (compat "8.4").
+Notation odd := Nat.odd (compat "8.4").
+Notation even_spec := Nat.even_spec (compat "8.4").
+Notation odd_spec := Nat.odd_spec (compat "8.4").
+
+Lemma Even_equiv n : Even n <-> Even.even n.
+Proof. symmetry. apply Even.even_equiv. Qed.
+Lemma Odd_equiv n : Odd n <-> Even.odd n.
+Proof. symmetry. apply Even.odd_equiv. Qed.
+
+Notation divmod := Nat.divmod (compat "8.4").
+Notation div := Nat.div (compat "8.4").
+Notation modulo := Nat.modulo (compat "8.4").
+Notation divmod_spec := Nat.divmod_spec (compat "8.4").
+Notation div_mod := Nat.div_mod (compat "8.4").
+Notation mod_bound_pos := Nat.mod_bound_pos (compat "8.4").
+Notation sqrt_iter := Nat.sqrt_iter (compat "8.4").
+Notation sqrt := Nat.sqrt (compat "8.4").
+Notation sqrt_iter_spec := Nat.sqrt_iter_spec (compat "8.4").
+Notation sqrt_spec := Nat.sqrt_spec (compat "8.4").
+Notation log2_iter := Nat.log2_iter (compat "8.4").
+Notation log2 := Nat.log2 (compat "8.4").
+Notation log2_iter_spec := Nat.log2_iter_spec (compat "8.4").
+Notation log2_spec := Nat.log2_spec (compat "8.4").
+Notation log2_nonpos := Nat.log2_nonpos (compat "8.4").
+Notation gcd := Nat.gcd (compat "8.4").
+Notation divide := Nat.divide (compat "8.4").
+Notation gcd_divide := Nat.gcd_divide (compat "8.4").
+Notation gcd_divide_l := Nat.gcd_divide_l (compat "8.4").
+Notation gcd_divide_r := Nat.gcd_divide_r (compat "8.4").
+Notation gcd_greatest := Nat.gcd_greatest (compat "8.4").
+Notation testbit := Nat.testbit (compat "8.4").
+Notation shiftl := Nat.shiftl (compat "8.4").
+Notation shiftr := Nat.shiftr (compat "8.4").
+Notation bitwise := Nat.bitwise (compat "8.4").
+Notation land := Nat.land (compat "8.4").
+Notation lor := Nat.lor (compat "8.4").
+Notation ldiff := Nat.ldiff (compat "8.4").
+Notation lxor := Nat.lxor (compat "8.4").
+Notation double_twice := Nat.double_twice (compat "8.4").
+Notation testbit_0_l := Nat.testbit_0_l (compat "8.4").
+Notation testbit_odd_0 := Nat.testbit_odd_0 (compat "8.4").
+Notation testbit_even_0 := Nat.testbit_even_0 (compat "8.4").
+Notation testbit_odd_succ := Nat.testbit_odd_succ (compat "8.4").
+Notation testbit_even_succ := Nat.testbit_even_succ (compat "8.4").
+Notation shiftr_spec := Nat.shiftr_spec (compat "8.4").
+Notation shiftl_spec_high := Nat.shiftl_spec_high (compat "8.4").
+Notation shiftl_spec_low := Nat.shiftl_spec_low (compat "8.4").
+Notation div2_bitwise := Nat.div2_bitwise (compat "8.4").
+Notation odd_bitwise := Nat.odd_bitwise (compat "8.4").
+Notation div2_decr := Nat.div2_decr (compat "8.4").
+Notation testbit_bitwise_1 := Nat.testbit_bitwise_1 (compat "8.4").
+Notation testbit_bitwise_2 := Nat.testbit_bitwise_2 (compat "8.4").
+Notation land_spec := Nat.land_spec (compat "8.4").
+Notation ldiff_spec := Nat.ldiff_spec (compat "8.4").
+Notation lor_spec := Nat.lor_spec (compat "8.4").
+Notation lxor_spec := Nat.lxor_spec (compat "8.4").
+
+Infix "<=?" := Nat.leb (at level 70) : nat_scope.
+Infix "<?" := Nat.ltb (at level 70) : nat_scope.
+Infix "^" := Nat.pow : nat_scope.
+Infix "/" := Nat.div : nat_scope.
+Infix "mod" := Nat.modulo (at level 40, no associativity) : nat_scope.
+Notation "( x | y )" := (Nat.divide x y) (at level 0) : nat_scope.
diff --git a/theories/Numbers/Rational/BigQ/BigQ.v b/theories/Numbers/Rational/BigQ/BigQ.v
index fe38ea4f..850afe53 100644
--- a/theories/Numbers/Rational/BigQ/BigQ.v
+++ b/theories/Numbers/Rational/BigQ/BigQ.v
@@ -104,18 +104,18 @@ Ltac isBigQcst t :=
  | BigQ.Qz ?t => isBigZcst t
  | BigQ.Qq ?n ?d => match isBigZcst n with
              | true => isBigNcst d
-             | false => constr:false
+             | false => constr:(false)
              end
- | BigQ.zero => constr:true
- | BigQ.one => constr:true
- | BigQ.minus_one => constr:true
- | _ => constr:false
+ | BigQ.zero => constr:(true)
+ | BigQ.one => constr:(true)
+ | BigQ.minus_one => constr:(true)
+ | _ => constr:(false)
  end.
 
 Ltac BigQcst t :=
  match isBigQcst t with
- | true => constr:t
- | false => constr:NotConstant
+ | true => constr:(t)
+ | false => constr:(NotConstant)
  end.
 
 Add Field BigQfield : BigQfieldth
diff --git a/theories/Numbers/Rational/BigQ/QMake.v b/theories/Numbers/Rational/BigQ/QMake.v
index 4ac36425..b9fed9d5 100644
--- a/theories/Numbers/Rational/BigQ/QMake.v
+++ b/theories/Numbers/Rational/BigQ/QMake.v
@@ -1050,13 +1050,13 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
  Theorem spec_of_Qc: forall q, [[of_Qc q]] = q.
  Proof.
  intros; apply Qc_decomp; simpl; intros.
- rewrite strong_spec_of_Qc; auto.
+ rewrite strong_spec_of_Qc. apply canon.
  Qed.
 
  Theorem spec_oppc: forall q, [[opp q]] = -[[q]].
  Proof.
  intros q; unfold Qcopp, to_Qc, Q2Qc.
- apply Qc_decomp; intros _ _; unfold this.
+ apply Qc_decomp; unfold this.
  apply Qred_complete.
  rewrite spec_opp, <- Qred_opp, Qred_correct.
  apply Qeq_refl.
@@ -1085,10 +1085,10 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
  unfold to_Qc.
  transitivity (Q2Qc ([x] + [y])).
  unfold Q2Qc.
- apply Qc_decomp; intros _ _; unfold this.
+ apply Qc_decomp; unfold this.
  apply Qred_complete; apply spec_add; auto.
  unfold Qcplus, Q2Qc.
- apply Qc_decomp; intros _ _; unfold this.
+ apply Qc_decomp; unfold this.
  apply Qred_complete.
  apply Qplus_comp; apply Qeq_sym; apply Qred_correct.
  Qed.
@@ -1099,10 +1099,10 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
  unfold to_Qc.
  transitivity (Q2Qc ([x] + [y])).
  unfold Q2Qc.
- apply Qc_decomp; intros _ _; unfold this.
+ apply Qc_decomp; unfold this.
  apply Qred_complete; apply spec_add_norm; auto.
  unfold Qcplus, Q2Qc.
- apply Qc_decomp; intros _ _; unfold this.
+ apply Qc_decomp; unfold this.
  apply Qred_complete.
  apply Qplus_comp; apply Qeq_sym; apply Qred_correct.
  Qed.
@@ -1147,10 +1147,10 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
  unfold to_Qc.
  transitivity (Q2Qc ([x] * [y])).
  unfold Q2Qc.
- apply Qc_decomp; intros _ _; unfold this.
+ apply Qc_decomp; unfold this.
  apply Qred_complete; apply spec_mul; auto.
  unfold Qcmult, Q2Qc.
- apply Qc_decomp; intros _ _; unfold this.
+ apply Qc_decomp; unfold this.
  apply Qred_complete.
  apply Qmult_comp; apply Qeq_sym; apply Qred_correct.
  Qed.
@@ -1161,10 +1161,10 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
  unfold to_Qc.
  transitivity (Q2Qc ([x] * [y])).
  unfold Q2Qc.
- apply Qc_decomp; intros _ _; unfold this.
+ apply Qc_decomp; unfold this.
  apply Qred_complete; apply spec_mul_norm; auto.
  unfold Qcmult, Q2Qc.
- apply Qc_decomp; intros _ _; unfold this.
+ apply Qc_decomp; unfold this.
  apply Qred_complete.
  apply Qmult_comp; apply Qeq_sym; apply Qred_correct.
  Qed.
@@ -1185,10 +1185,10 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
  unfold to_Qc.
  transitivity (Q2Qc (/[x])).
  unfold Q2Qc.
- apply Qc_decomp; intros _ _; unfold this.
+ apply Qc_decomp; unfold this.
  apply Qred_complete; apply spec_inv; auto.
  unfold Qcinv, Q2Qc.
- apply Qc_decomp; intros _ _; unfold this.
+ apply Qc_decomp; unfold this.
  apply Qred_complete.
  apply Qinv_comp; apply Qeq_sym; apply Qred_correct.
  Qed.
@@ -1199,10 +1199,10 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
  unfold to_Qc.
  transitivity (Q2Qc (/[x])).
  unfold Q2Qc.
- apply Qc_decomp; intros _ _; unfold this.
+ apply Qc_decomp; unfold this.
  apply Qred_complete; apply spec_inv_norm; auto.
  unfold Qcinv, Q2Qc.
- apply Qc_decomp; intros _ _; unfold this.
+ apply Qc_decomp; unfold this.
  apply Qred_complete.
  apply Qinv_comp; apply Qeq_sym; apply Qred_correct.
  Qed.
@@ -1247,13 +1247,13 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
  unfold to_Qc.
  transitivity (Q2Qc ([x]^2)).
  unfold Q2Qc.
- apply Qc_decomp; intros _ _; unfold this.
+ apply Qc_decomp; unfold this.
  apply Qred_complete; apply spec_square; auto.
  simpl Qcpower.
  replace (Q2Qc [x] * 1) with (Q2Qc [x]); try ring.
  simpl.
  unfold Qcmult, Q2Qc.
- apply Qc_decomp; intros _ _; unfold this.
+ apply Qc_decomp; unfold this.
  apply Qred_complete.
  apply Qmult_comp; apply Qeq_sym; apply Qred_correct.
  Qed.
@@ -1264,14 +1264,14 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
  unfold to_Qc.
  transitivity (Q2Qc ([x]^Zpos p)).
  unfold Q2Qc.
- apply Qc_decomp; intros _ _; unfold this.
+ apply Qc_decomp; unfold this.
  apply Qred_complete; apply spec_power_pos; auto.
  induction p using Pos.peano_ind.
  simpl; ring.
  rewrite Pos2Nat.inj_succ; simpl Qcpower.
  rewrite <- IHp; clear IHp.
  unfold Qcmult, Q2Qc.
- apply Qc_decomp; intros _ _; unfold this.
+ apply Qc_decomp; unfold this.
  apply Qred_complete.
  setoid_replace ([x] ^ ' Pos.succ p)%Q with ([x] * [x] ^ ' p)%Q.
  apply Qmult_comp; apply Qeq_sym; apply Qred_correct.
@@ -1281,4 +1281,3 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
  Qed.
 
 End Make.
-
diff --git a/theories/Numbers/Rational/SpecViaQ/QSig.v b/theories/Numbers/Rational/SpecViaQ/QSig.v
index a40d9405..8e20fd06 100644
--- a/theories/Numbers/Rational/SpecViaQ/QSig.v
+++ b/theories/Numbers/Rational/SpecViaQ/QSig.v
@@ -115,7 +115,10 @@ Ltac solve_wd2 := intros x x' Hx y y' Hy; qify; now rewrite Hx, Hy.
 Local Obligation Tactic := solve_wd2 || solve_wd1.
 
 Instance : Measure to_Q.
-Instance eq_equiv : Equivalence eq := {}.
+Instance eq_equiv : Equivalence eq.
+Proof.
+  change eq with (RelCompFun Qeq to_Q); apply _.
+Defined.
 
 Program Instance lt_wd : Proper (eq==>eq==>iff) lt.
 Program Instance le_wd : Proper (eq==>eq==>iff) le.
@@ -141,7 +144,10 @@ Proof. intros. qify. destruct (Qcompare_spec [x] [y]); auto. Qed.
 (** Let's implement [TotalOrder] *)
 
 Definition lt_compat := lt_wd.
-Instance lt_strorder : StrictOrder lt := {}.
+Instance lt_strorder : StrictOrder lt.
+Proof.
+  change lt with (RelCompFun Qlt to_Q); apply _.
+Qed.
 
 Lemma le_lteq : forall x y, x<=y <-> x<y \/ x==y.
 Proof. intros. qify. apply Qle_lteq. Qed.
diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v
index 0ccfad7b..7baf102a 100644
--- a/theories/PArith/BinPos.v
+++ b/theories/PArith/BinPos.v
@@ -201,7 +201,6 @@ Proof.
 Qed.
 
 (** ** No neutral elements for addition *)
-
 Lemma add_no_neutral p q : q + p <> p.
 Proof.
   revert q.
@@ -508,7 +507,7 @@ Qed.
 Lemma mul_xO_discr p q : p~0 * q <> q.
 Proof.
   induction q; try discriminate.
-  rewrite mul_xO_r; injection; assumption.
+  rewrite mul_xO_r; injection; auto.
 Qed.
 
 (** ** Simplification properties of multiplication *)
diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v
index 27e1ca84..d6f9bb9d 100644
--- a/theories/Program/Equality.v
+++ b/theories/Program/Equality.v
@@ -8,7 +8,6 @@
 
 (** Tactics related to (dependent) equality and proof irrelevance. *)
 
-Require Export ProofIrrelevance.
 Require Export JMeq.
 
 Require Import Coq.Program.Tactics.
@@ -143,7 +142,7 @@ Ltac pi_eq_proof_hyp p :=
       | [ H : X = Y |- _ ] =>
         match p with
           | H => fail 2
-          | _ => rewrite (proof_irrelevance (X = Y) p H)
+          | _ => rewrite (UIP _ X Y p H)
         end
       | _ => fail " No hypothesis with same type "
     end
@@ -166,7 +165,7 @@ Hint Rewrite <- eq_rect_eq : refl_id.
    [coerce_* t eq_refl = t]. *)
 
 Lemma JMeq_eq_refl {A} (x : A) : JMeq_eq (@JMeq_refl _ x) = eq_refl.
-Proof. apply proof_irrelevance. Qed.
+Proof. apply UIP. Qed.
 
 Lemma UIP_refl_refl A (x : A) :
   Eqdep.EqdepTheory.UIP_refl A x eq_refl = eq_refl.
@@ -238,8 +237,8 @@ Ltac inject_left H :=
 Ltac inject_right H :=
   progress (inversion H ; subst_right_no_fail ; clear_dups) ; clear H.
 
-Ltac autoinjections_left := repeat autoinjection ltac:inject_left.
-Ltac autoinjections_right := repeat autoinjection ltac:inject_right.
+Ltac autoinjections_left := repeat autoinjection ltac:(inject_left).
+Ltac autoinjections_right := repeat autoinjection ltac:(inject_right).
 
 Ltac simpl_depind := subst_no_fail ; autoinjections ; try discriminates ; 
   simpl_JMeq ; simpl_existTs ; simplify_IH_hyps.
@@ -333,7 +332,7 @@ Ltac simplify_one_dep_elim_term c :=
       (let hyp := fresh in intros hyp ;
         move hyp before y ; revert_until hyp ; generalize dependent y ;
           refine (solution_right _ _ _ _)(*  ; intros until 0 *))
-    | ?f ?x = ?g ?y -> _ => let H := fresh in progress (intros H ; injection H ; clear H)
+    | ?f ?x = ?g ?y -> _ => let H := fresh in progress (intros H ; simple injection H; clear H)
     | ?t = ?u -> _ => let hyp := fresh in
       intros hyp ; exfalso ; discriminate
     | ?x = ?y -> _ => let hyp := fresh in
diff --git a/theories/Program/Subset.v b/theories/Program/Subset.v
index c8f37318..2a3ec926 100644
--- a/theories/Program/Subset.v
+++ b/theories/Program/Subset.v
@@ -9,6 +9,7 @@
 
 Require Import Coq.Program.Utils.
 Require Import Coq.Program.Equality.
+Require Export ProofIrrelevance.
 
 Local Open Scope program_scope.
 
diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v
index 66ca3e57..dfd6b0ea 100644
--- a/theories/Program/Tactics.v
+++ b/theories/Program/Tactics.v
@@ -252,7 +252,7 @@ Ltac autoinjection tac :=
 
 Ltac inject H := progress (inversion H ; subst*; clear_dups) ; clear H.
 
-Ltac autoinjections := repeat (clear_dups ; autoinjection ltac:inject).
+Ltac autoinjections := repeat (clear_dups ; autoinjection ltac:(inject)).
 
 (** Destruct an hypothesis by first copying it to avoid dependencies. *)
 
@@ -264,7 +264,7 @@ Ltac bang :=
   match goal with
     | |- ?x =>
       match x with
-        | appcontext [False_rect _ ?p] => elim p
+        | context [False_rect _ ?p] => elim p
       end
   end.
 
diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v
index 154200d7..c490ea51 100644
--- a/theories/Program/Wf.v
+++ b/theories/Program/Wf.v
@@ -89,7 +89,7 @@ Section Measure_well_founded.
   Lemma measure_wf: well_founded MR.
   Proof with auto.
     unfold well_founded.
-    cut (forall a: M, (fun mm: M => forall a0: T, m a0 = mm -> Acc MR a0) a).
+    cut (forall (a: M) (a0: T), m a0 = a -> Acc MR a0).
       intros.
       apply (H (m a))...
     apply (@well_founded_ind M R wf (fun mm => forall a, m a = mm -> Acc MR a)).
@@ -211,7 +211,7 @@ Ltac fold_sub f :=
   match goal with
     | [ |- ?T ] =>
       match T with
-        appcontext C [ @Fix_sub _ _ _ _ _ ?arg ] =>
+        context C [ @Fix_sub _ _ _ _ _ ?arg ] =>
         let app := context C [ f arg ] in
           change app
       end
diff --git a/theories/QArith/Qcabs.v b/theories/QArith/Qcabs.v
new file mode 100644
index 00000000..c0ababff
--- /dev/null
+++ b/theories/QArith/Qcabs.v
@@ -0,0 +1,129 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** * An absolute value for normalized rational numbers. *)
+
+(** Contributed by Cédric Auger *)
+
+Require Import Qabs Qcanon.
+
+Lemma Qred_abs (x : Q) : Qred (Qabs x) = Qabs (Qred x).
+Proof.
+  destruct x as [[|a|a] d]; simpl; auto;
+  destruct (Pos.ggcd a d) as [x [y z]]; simpl; auto.
+Qed.
+
+Lemma Qcabs_canon (x : Q) : Qred x = x -> Qred (Qabs x) = Qabs x.
+Proof. intros H; now rewrite (Qred_abs x), H. Qed.
+
+Definition Qcabs (x:Qc) : Qc := {| canon := Qcabs_canon x (canon x) |}.
+Notation "[ q ]" := (Qcabs q) (q at next level, format "[ q ]") : Qc_scope.
+
+Ltac Qc_unfolds :=
+  unfold Qcabs, Qcminus, Qcopp, Qcplus, Qcmult, Qcle, Q2Qc, this.
+
+Lemma Qcabs_case (x:Qc) (P : Qc -> Type) :
+  (0 <= x -> P x) -> (x <= 0 -> P (- x)) -> P [x].
+Proof.
+  intros A B.
+  apply (Qabs_case x (fun x => forall Hx, P {|this:=x;canon:=Hx|})).
+  intros; case (Qc_decomp x {|canon:=Hx|}); auto.
+  intros; case (Qc_decomp (-x) {|canon:=Hx|}); auto.
+Qed.
+
+Lemma Qcabs_pos x : 0 <= x -> [x] = x.
+Proof.
+  intro Hx; apply Qc_decomp; Qc_unfolds; fold (this x).
+  set (K := canon [x]); simpl in K; case K; clear K.
+  set (a := x) at 1; case (canon x); subst a; apply Qred_complete.
+  now apply Qabs_pos.
+Qed.
+
+Lemma Qcabs_neg x : x <= 0 -> [x] = - x.
+Proof.
+  intro Hx; apply Qc_decomp; Qc_unfolds; fold (this x).
+  set (K := canon [x]); simpl in K; case K; clear K.
+  now apply Qred_complete; apply Qabs_neg.
+Qed.
+
+Lemma Qcabs_nonneg x : 0 <= [x].
+Proof. intros; apply Qabs_nonneg. Qed.
+
+Lemma Qcabs_opp x : [(-x)] = [x].
+Proof.
+  apply Qc_decomp; Qc_unfolds; fold (this x).
+  set (K := canon [x]); simpl in K; case K; clear K.
+  case Qred_abs; apply Qred_complete; apply Qabs_opp.
+Qed.
+
+Lemma Qcabs_triangle x y : [x+y] <= [x] + [y].
+Proof.
+  Qc_unfolds; case Qred_abs; rewrite !Qred_le; apply Qabs_triangle.
+Qed.
+
+Lemma Qcabs_Qcmult x y : [x*y] = [x]*[y].
+Proof.
+  apply Qc_decomp; Qc_unfolds; fold (this x) (this y); case Qred_abs.
+  apply Qred_complete; apply Qabs_Qmult.
+Qed.
+
+Lemma Qcabs_Qcminus x y: [x-y] = [y-x].
+Proof.
+  apply Qc_decomp; Qc_unfolds; fold (this x) (this y) (this (-x)) (this (-y)).
+  set (a := x) at 2; case (canon x); subst a.
+  set (a := y) at 1; case (canon y); subst a.
+  rewrite !Qred_opp; fold (Qred x - Qred y)%Q (Qred y - Qred x)%Q.
+  repeat case Qred_abs; f_equal; apply Qabs_Qminus.
+Qed.
+
+Lemma Qcle_Qcabs x : x <= [x].
+Proof. apply Qle_Qabs. Qed.
+
+Lemma Qcabs_triangle_reverse x y : [x] - [y] <= [x - y].
+Proof.
+  unfold Qcle, Qcabs, Qcminus, Qcplus, Qcopp, Q2Qc, this;
+  fold (this x) (this y) (this (-x)) (this (-y)).
+  case Qred_abs; rewrite !Qred_le, !Qred_opp, Qred_abs.
+  apply Qabs_triangle_reverse.
+Qed.
+
+Lemma Qcabs_Qcle_condition x y : [x] <= y <-> -y <= x <= y.
+Proof.
+  Qc_unfolds; fold (this x) (this y).
+  destruct (Qabs_Qle_condition x y) as [A B].
+  split; intros H.
+  + destruct (A H) as [X Y]; split; auto.
+    now case (canon x); apply Qred_le.
+  + destruct H as [X Y]; apply B; split; auto.
+    now case (canon y); case Qred_opp.
+Qed.
+
+Lemma Qcabs_diff_Qcle_condition x y r : [x-y] <= r <-> x - r <= y <= x + r.
+Proof.
+  Qc_unfolds; fold (this x) (this y) (this r).
+  case Qred_abs; repeat rewrite Qred_opp.
+  set (a := y) at 1; case (canon y); subst a.
+  set (a := r) at 2; case (canon r); subst a.
+  set (a := Qred r) at 2 3;
+  assert (K := canon (Q2Qc r)); simpl in K; case K; clear K; subst a.
+  set (a := Qred y) at 1;
+  assert (K := canon (Q2Qc y)); simpl in K; case K; clear K; subst a.
+  fold (x - Qred y)%Q (x - Qred r)%Q.
+  destruct (Qabs_diff_Qle_condition x (Qred y) (Qred r)) as [A B].
+  split.
+  + clear B; rewrite !Qred_le. auto.
+  + clear A; rewrite !Qred_le. auto.
+Qed.
+
+Lemma Qcabs_null x : [x] = 0 -> x = 0.
+Proof.
+  intros H.
+  destruct (proj1 (Qcabs_Qcle_condition x 0)) as [A B].
+  + rewrite H; apply Qcle_refl.
+  + apply Qcle_antisym; auto.
+Qed.
\ No newline at end of file
diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v
index d966b050..9f9651d8 100644
--- a/theories/QArith/Qcanon.v
+++ b/theories/QArith/Qcanon.v
@@ -21,37 +21,30 @@ Bind Scope Qc_scope with Qc.
 Arguments Qcmake this%Q _.
 Open Scope Qc_scope.
 
+(** An alternative statement of [Qred q = q] via [Z.gcd] *)
+
 Lemma Qred_identity :
   forall q:Q, Z.gcd (Qnum q) (QDen q) = 1%Z -> Qred q = q.
 Proof.
-  unfold Qred; intros (a,b); simpl.
-  generalize (Z.ggcd_gcd a ('b)) (Z.ggcd_correct_divisors a ('b)).
-  intros.
-  rewrite H1 in H; clear H1.
-  destruct (Z.ggcd a ('b)) as (g,(aa,bb)); simpl in *; subst.
-  destruct H0.
-  rewrite Z.mul_1_l in H, H0.
-  subst; simpl; auto.
+  intros (a,b) H; simpl in *.
+  rewrite <- Z.ggcd_gcd in H.
+  generalize (Z.ggcd_correct_divisors a ('b)).
+  destruct Z.ggcd as (g,(aa,bb)); simpl in *; subst.
+  rewrite !Z.mul_1_l. now intros (<-,<-).
 Qed.
 
 Lemma Qred_identity2 :
   forall q:Q, Qred q = q -> Z.gcd (Qnum q) (QDen q) = 1%Z.
 Proof.
-  unfold Qred; intros (a,b); simpl.
-  generalize (Z.ggcd_gcd a ('b)) (Z.ggcd_correct_divisors a ('b)) (Z.gcd_nonneg a ('b)).
-  intros.
-  rewrite <- H; rewrite <- H in H1; clear H.
-  destruct (Z.ggcd a ('b)) as (g,(aa,bb)); simpl in *; subst.
-  injection H2; intros; clear H2.
-  destruct H0.
-  clear H0 H3.
-  destruct g as [|g|g]; destruct bb as [|bb|bb]; simpl in *; try discriminate.
-  f_equal.
-  apply Pos.mul_reg_r with bb.
-  injection H2; intros.
-  rewrite <- H0.
-  rewrite H; simpl; auto.
-  elim H1; auto.
+  intros (a,b) H; simpl in *.
+  generalize (Z.gcd_nonneg a ('b)) (Z.ggcd_correct_divisors a ('b)).
+  rewrite <- Z.ggcd_gcd.
+  destruct Z.ggcd as (g,(aa,bb)); simpl in *.
+  injection H as <- <-. intros H (_,H').
+  destruct g as [|g|g]; [ discriminate | | now elim H ].
+  destruct bb as [|b|b]; simpl in *; try discriminate.
+  injection H' as H'. f_equal.
+  apply Pos.mul_reg_r with b. now rewrite Pos.mul_1_l.
 Qed.
 
 Lemma Qred_iff : forall q:Q, Qred q = q <-> Z.gcd (Qnum q) (QDen q) = 1%Z.
@@ -61,6 +54,23 @@ Proof.
   apply Qred_identity; auto.
 Qed.
 
+(** Coercion from [Qc] to [Q] and equality *)
+
+Lemma Qc_is_canon : forall q q' : Qc, q == q' -> q = q'.
+Proof.
+  intros (q,hq) (q',hq') H. simpl in *.
+  assert (H' := Qred_complete _ _ H).
+  rewrite hq, hq' in H'. subst q'. f_equal.
+  apply eq_proofs_unicity. intros.  repeat decide equality.
+Qed.
+Hint Resolve Qc_is_canon.
+
+Theorem Qc_decomp: forall q q': Qc, (q:Q) = q' -> q = q'.
+Proof.
+  intros. apply Qc_is_canon. now rewrite H.
+Qed.
+
+(** [Q2Qc] : a conversion from [Q] to [Qc]. *)
 
 Lemma Qred_involutive : forall q:Q, Qred (Qred q) = Qred q.
 Proof.
@@ -71,20 +81,12 @@ Qed.
 Definition Q2Qc (q:Q) : Qc := Qcmake (Qred q) (Qred_involutive q).
 Arguments Q2Qc q%Q.
 
-Lemma Qc_is_canon : forall q q' : Qc, q == q' -> q = q'.
+Lemma Q2Qc_eq_iff (q q' : Q) : Q2Qc q = Q2Qc q' <-> q == q'.
 Proof.
-  intros (q,proof_q) (q',proof_q').
-  simpl.
-  intros H.
-  assert (H0:=Qred_complete _ _ H).
-  assert (q = q') by congruence.
-  subst q'.
-  assert (proof_q = proof_q').
-  apply eq_proofs_unicity; auto; intros.
-  repeat decide equality.
-  congruence.
+ split; intro H.
+ - now injection H as H%Qred_eq_iff.
+ - apply Qc_is_canon. simpl. now rewrite H.
 Qed.
-Hint Resolve Qc_is_canon.
 
 Notation " 0 " := (Q2Qc 0) : Qc_scope.
 Notation " 1 " := (Q2Qc 1) : Qc_scope.
@@ -107,8 +109,7 @@ Lemma Qceq_alt : forall p q, (p = q) <-> (p ?= q) = Eq.
 Proof.
   unfold Qccompare.
   intros; rewrite <- Qeq_alt.
-  split; auto.
-  intro H; rewrite H; auto with qarith.
+  split; auto. now intros <-.
 Qed.
 
 Lemma Qclt_alt : forall p q, (p<q) <-> (p?=q = Lt).
@@ -121,12 +122,12 @@ Proof.
   intros; exact (Qgt_alt p q).
 Qed.
 
-Lemma Qle_alt : forall p q, (p<=q) <-> (p?=q <> Gt).
+Lemma Qcle_alt : forall p q, (p<=q) <-> (p?=q <> Gt).
 Proof.
   intros; exact (Qle_alt p q).
 Qed.
 
-Lemma Qge_alt : forall p q, (p>=q) <-> (p?=q <> Lt).
+Lemma Qcge_alt : forall p q, (p>=q) <-> (p?=q <> Lt).
 Proof.
   intros; exact (Qge_alt p q).
 Qed.
@@ -166,7 +167,7 @@ Qed.
 
 Ltac qc := match goal with
  | q:Qc |- _ => destruct q; qc
- | _ => apply Qc_is_canon; simpl; repeat rewrite Qred_correct
+ | _ => apply Qc_is_canon; simpl; rewrite !Qred_correct
 end.
 
 Opaque Qred.
@@ -216,6 +217,18 @@ Proof.
   intros; qc; apply Qmult_assoc.
 Qed.
 
+(** [0] is absorbing for multiplication: *)
+
+Lemma Qcmult_0_l : forall n, 0*n = 0.
+Proof.
+  intros; qc; split.
+Qed.
+
+Theorem Qcmult_0_r : forall n, n*0=0.
+Proof.
+  intros; qc; rewrite Qmult_comm; split.
+Qed.
+
 (** [1] is a neutral element for multiplication: *)
 
 Lemma Qcmult_1_l : forall n, 1*n = n.
@@ -253,7 +266,7 @@ Theorem Qcmult_integral : forall x y, x*y=0 -> x=0 \/ y=0.
 Proof.
   intros.
   destruct (Qmult_integral x y); try qc; auto.
-  injection H; clear H; intros.
+  injection H as H.
   rewrite <- (Qred_correct (x*y)).
   rewrite <- (Qred_correct 0).
   rewrite H; auto with qarith.
@@ -303,7 +316,7 @@ Proof.
   apply Qcmult_1_l.
 Qed.
 
-(** Properties of order upon Q. *)
+(** Properties of order upon Qc. *)
 
 Lemma Qcle_refl : forall x, x<=x.
 Proof.
@@ -372,9 +385,11 @@ Proof.
   unfold Qcle, Qclt; intros; apply Qle_not_lt; auto.
 Qed.
 
-Lemma Qcle_lt_or_eq : forall x y, x<=y -> x<y \/ x==y.
+Lemma Qcle_lt_or_eq : forall x y, x<=y -> x<y \/ x=y.
 Proof.
-  unfold Qcle, Qclt; intros; apply Qle_lt_or_eq; auto.
+  unfold Qcle, Qclt; intros x y H.
+  destruct (Qle_lt_or_eq _ _ H); [left|right]; trivial.
+  now apply Qc_is_canon.
 Qed.
 
 (** Some decidability results about orders. *)
@@ -459,13 +474,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.
@@ -525,16 +540,3 @@ intros.
 field.
 auto.
 Qed.
-
-
-Theorem Qc_decomp: forall x y: Qc,
-  (Qred x = x -> Qred y = y -> (x:Q) = y)-> x = y.
-Proof.
-  intros (q, Hq) (q', Hq'); simpl; intros H.
-  assert (H1 := H Hq Hq').
-  subst q'.
-  assert (Hq = Hq').
-  apply Eqdep_dec.eq_proofs_unicity; auto; intros.
-  repeat decide equality.
-  congruence.
-Qed.
diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v
index c50c38b2..131214f5 100644
--- a/theories/QArith/Qreduction.v
+++ b/theories/QArith/Qreduction.v
@@ -93,11 +93,17 @@ Proof.
   Close Scope Z_scope.
 Qed.
 
+Lemma Qred_eq_iff q q' : Qred q = Qred q' <-> q == q'.
+Proof.
+ split.
+ - intros E. rewrite <- (Qred_correct q), <- (Qred_correct q').
+   now rewrite E.
+ - apply Qred_complete.
+Qed.
+
 Add Morphism Qred : Qred_comp.
 Proof.
-  intros q q' H.
-  rewrite (Qred_correct q); auto.
-  rewrite (Qred_correct q'); auto.
+  intros. now rewrite !Qred_correct.
 Qed.
 
 Definition Qplus' (p q : Q) := Qred (Qplus p q).
@@ -149,3 +155,13 @@ Theorem Qred_compare: forall x y,
 Proof.
   intros x y; apply Qcompare_comp; apply Qeq_sym; apply Qred_correct.
 Qed.
+
+Lemma Qred_le q q' : Qred q <= Qred q' <-> q <= q'.
+Proof.
+  now rewrite !Qle_alt, <- Qred_compare.
+Qed.
+
+Lemma Qred_lt q q' : Qred q < Qred q' <-> q < q'.
+Proof.
+  now rewrite !Qlt_alt, <- Qred_compare.
+Qed.
diff --git a/theories/QArith/vo.itarget b/theories/QArith/vo.itarget
index b3faef88..b550b471 100644
--- a/theories/QArith/vo.itarget
+++ b/theories/QArith/vo.itarget
@@ -2,6 +2,7 @@ Qabs.vo
 QArith_base.vo
 QArith.vo
 Qcanon.vo
+Qcabs.vo
 Qfield.vo
 Qpower.vo
 Qreals.vo
diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v
index f26bac2b..379fee6f 100644
--- a/theories/Reals/RIneq.v
+++ b/theories/Reals/RIneq.v
@@ -389,7 +389,7 @@ Lemma Rplus_ne : forall r, r + 0 = r /\ 0 + r = r.
 Proof.
   split; ring.
 Qed.
-Hint Resolve Rplus_ne: real v62.
+Hint Resolve Rplus_ne: real.
 
 (**********)
 
@@ -425,7 +425,6 @@ Proof.
   apply (f_equal (fun v => v + r)).
 Qed.
 
-(*i Old i*)Hint Resolve Rplus_eq_compat_l: v62.
 
 (**********)
 Lemma Rplus_eq_reg_l : forall r r1 r2, r + r1 = r + r2 -> r1 = r2.
@@ -501,21 +500,21 @@ Lemma Rmult_0_r : forall r, r * 0 = 0.
 Proof.
   intro; ring.
 Qed.
-Hint Resolve Rmult_0_r: real v62.
+Hint Resolve Rmult_0_r: real.
 
 (**********)
 Lemma Rmult_0_l : forall r, 0 * r = 0.
 Proof.
   intro; ring.
 Qed.
-Hint Resolve Rmult_0_l: real v62.
+Hint Resolve Rmult_0_l: real.
 
 (**********)
 Lemma Rmult_ne : forall r, r * 1 = r /\ 1 * r = r.
 Proof.
   intro; split; ring.
 Qed.
-Hint Resolve Rmult_ne: real v62.
+Hint Resolve Rmult_ne: real.
 
 (**********)
 Lemma Rmult_1_r : forall r, r * 1 = r.
@@ -530,7 +529,6 @@ Proof.
   auto with real.
 Qed.
 
-(*i Old i*)Hint Resolve Rmult_eq_compat_l: v62.
 
 Lemma Rmult_eq_compat_r : forall r r1 r2, r1 = r2 -> r1 * r = r2 * r.
 Proof.
@@ -646,7 +644,7 @@ Lemma Ropp_0 : -0 = 0.
 Proof.
   ring.
 Qed.
-Hint Resolve Ropp_0: real v62.
+Hint Resolve Ropp_0: real.
 
 (**********)
 Lemma Ropp_eq_0_compat : forall r, r = 0 -> - r = 0.
diff --git a/theories/Reals/Ranalysis_reg.v b/theories/Reals/Ranalysis_reg.v
index 2465f039..0c27d407 100644
--- a/theories/Reals/Ranalysis_reg.v
+++ b/theories/Reals/Ranalysis_reg.v
@@ -35,7 +35,7 @@ Qed.
 
 (**********)
 Ltac intro_hyp_glob trm :=
-  match constr:trm with
+  match constr:(trm) with
     | (?X1 + ?X2)%F =>
       match goal with
         |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
@@ -55,7 +55,7 @@ Ltac intro_hyp_glob trm :=
         | _ => idtac
       end
     | (?X1 / ?X2)%F =>
-      let aux := constr:X2 in
+      let aux := constr:(X2) in
         match goal with
           | _:(forall x0:R, aux x0 <> 0) |- (derivable _) =>
             intro_hyp_glob X1; intro_hyp_glob X2
@@ -82,7 +82,7 @@ Ltac intro_hyp_glob trm :=
         | _ => idtac
       end
     | (/ ?X1)%F =>
-      let aux := constr:X1 in
+      let aux := constr:(X1) in
         match goal with
           | _:(forall x0:R, aux x0 <> 0) |- (derivable _) =>
             intro_hyp_glob X1
@@ -108,7 +108,8 @@ Ltac intro_hyp_glob trm :=
     | (pow_fct _) => idtac
     | Rabs => idtac
     | ?X1 =>
-      let p := constr:X1 in
+      let p := constr:(X1) in
+      let HYPPD := fresh "HYPPD" in
         match goal with
           | _:(derivable p) |- _ => idtac
           |  |- (derivable p) => idtac
@@ -130,7 +131,7 @@ Ltac intro_hyp_glob trm :=
 
 (**********)
 Ltac intro_hyp_pt trm pt :=
-  match constr:trm with
+  match constr:(trm) with
     | (?X1 + ?X2)%F =>
       match goal with
         |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
@@ -156,7 +157,7 @@ Ltac intro_hyp_pt trm pt :=
         | _ => idtac
       end
     | (?X1 / ?X2)%F =>
-      let aux := constr:X2 in
+      let aux := constr:(X2) in
         match goal with
           | _:(aux pt <> 0) |- (derivable_pt _ _) =>
             intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
@@ -202,7 +203,7 @@ Ltac intro_hyp_pt trm pt :=
         | _ => idtac
       end
     | (/ ?X1)%F =>
-      let aux := constr:X1 in
+      let aux := constr:(X1) in
         match goal with
           | _:(aux pt <> 0) |- (derivable_pt _ _) =>
             intro_hyp_pt X1 pt
@@ -249,7 +250,8 @@ Ltac intro_hyp_pt trm pt :=
         | _ => idtac
       end
     | ?X1 =>
-      let p := constr:X1 in
+      let p := constr:(X1) in
+      let HYPPD := fresh "HYPPD" in
         match goal with
           | _:(derivable_pt p pt) |- _ => idtac
           |  |- (derivable_pt p pt) => idtac
@@ -341,8 +343,10 @@ Ltac is_diff_pt :=
     | _:(derivable_pt ?X1 ?X2) |- (derivable_pt ?X1 ?X2) =>
       assumption
     | _:(derivable ?X1) |- (derivable_pt ?X1 ?X2) =>
+      let HypDDPT := fresh "HypDDPT" in
       cut (derivable X1); [ intro HypDDPT; apply HypDDPT | assumption ]
     |  |- (True -> derivable_pt _ _) =>
+      let HypTruE := fresh "HypTruE" in
       intro HypTruE; clear HypTruE; is_diff_pt
     | _ =>
       try
@@ -411,6 +415,7 @@ Ltac is_diff_glob :=
       apply (derivable_comp X2 X1); is_diff_glob
     | _:(derivable ?X1) |- (derivable ?X1) => assumption
     |  |- (True -> derivable _) =>
+      let HypTruE := fresh "HypTruE" in
       intro HypTruE; clear HypTruE; is_diff_glob
     | _ =>
       try
@@ -490,14 +495,17 @@ Ltac is_cont_pt :=
     | _:(continuity_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) =>
       assumption
     | _:(continuity ?X1) |- (continuity_pt ?X1 ?X2) =>
+      let HypDDPT := fresh "HypDDPT" in
       cut (continuity X1); [ intro HypDDPT; apply HypDDPT | assumption ]
     | _:(derivable_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) =>
       apply derivable_continuous_pt; assumption
     | _:(derivable ?X1) |- (continuity_pt ?X1 ?X2) =>
+      let HypDDPT := fresh "HypDDPT" in
       cut (continuity X1);
         [ intro HypDDPT; apply HypDDPT
           | apply derivable_continuous; assumption ]
     |  |- (True -> continuity_pt _ _) =>
+      let HypTruE := fresh "HypTruE" in
       intro HypTruE; clear HypTruE; is_cont_pt
     | _ =>
       try
@@ -567,6 +575,7 @@ Ltac is_cont_glob :=
       apply (continuity_comp X2 X1); try is_cont_glob || assumption
     | _:(continuity ?X1) |- (continuity ?X1) => assumption
     |  |- (True -> continuity _) =>
+      let HypTruE := fresh "HypTruE" in
       intro HypTruE; clear HypTruE; is_cont_glob
     | _:(derivable ?X1) |- (continuity ?X1) =>
       apply derivable_continuous; assumption
@@ -578,89 +587,89 @@ Ltac is_cont_glob :=
 
 (**********)
 Ltac rew_term trm :=
-  match constr:trm with
+  match constr:(trm) with
     | (?X1 + ?X2) =>
       let p1 := rew_term X1 with p2 := rew_term X2 in
-        match constr:p1 with
+        match constr:(p1) with
           | (fct_cte ?X3) =>
-            match constr:p2 with
+            match constr:(p2) with
               | (fct_cte ?X4) => constr:(fct_cte (X3 + X4))
-              | _ => constr:(p1 + p2)%F
+              | _ => constr:((p1 + p2)%F)
             end
-          | _ => constr:(p1 + p2)%F
+          | _ => constr:((p1 + p2)%F)
         end
     | (?X1 - ?X2) =>
       let p1 := rew_term X1 with p2 := rew_term X2 in
-        match constr:p1 with
+        match constr:(p1) with
           | (fct_cte ?X3) =>
-            match constr:p2 with
+            match constr:(p2) with
               | (fct_cte ?X4) => constr:(fct_cte (X3 - X4))
-              | _ => constr:(p1 - p2)%F
+              | _ => constr:((p1 - p2)%F)
             end
-          | _ => constr:(p1 - p2)%F
+          | _ => constr:((p1 - p2)%F)
         end
     | (?X1 / ?X2) =>
       let p1 := rew_term X1 with p2 := rew_term X2 in
-        match constr:p1 with
+        match constr:(p1) with
           | (fct_cte ?X3) =>
-            match constr:p2 with
+            match constr:(p2) with
               | (fct_cte ?X4) => constr:(fct_cte (X3 / X4))
-              | _ => constr:(p1 / p2)%F
+              | _ => constr:((p1 / p2)%F)
             end
           | _ =>
-            match constr:p2 with
-              | (fct_cte ?X4) => constr:(p1 * fct_cte (/ X4))%F
-              | _ => constr:(p1 / p2)%F
+            match constr:(p2) with
+              | (fct_cte ?X4) => constr:((p1 * fct_cte (/ X4))%F)
+              | _ => constr:((p1 / p2)%F)
             end
         end
     | (?X1 * / ?X2) =>
       let p1 := rew_term X1 with p2 := rew_term X2 in
-        match constr:p1 with
+        match constr:(p1) with
           | (fct_cte ?X3) =>
-            match constr:p2 with
+            match constr:(p2) with
               | (fct_cte ?X4) => constr:(fct_cte (X3 / X4))
-              | _ => constr:(p1 / p2)%F
+              | _ => constr:((p1 / p2)%F)
             end
           | _ =>
-            match constr:p2 with
-              | (fct_cte ?X4) => constr:(p1 * fct_cte (/ X4))%F
-              | _ => constr:(p1 / p2)%F
+            match constr:(p2) with
+              | (fct_cte ?X4) => constr:((p1 * fct_cte (/ X4))%F)
+              | _ => constr:((p1 / p2)%F)
             end
         end
     | (?X1 * ?X2) =>
       let p1 := rew_term X1 with p2 := rew_term X2 in
-        match constr:p1 with
+        match constr:(p1) with
           | (fct_cte ?X3) =>
-            match constr:p2 with
+            match constr:(p2) with
               | (fct_cte ?X4) => constr:(fct_cte (X3 * X4))
-              | _ => constr:(p1 * p2)%F
+              | _ => constr:((p1 * p2)%F)
             end
-          | _ => constr:(p1 * p2)%F
+          | _ => constr:((p1 * p2)%F)
         end
     | (- ?X1) =>
       let p := rew_term X1 in
-        match constr:p with
+        match constr:(p) with
           | (fct_cte ?X2) => constr:(fct_cte (- X2))
-          | _ => constr:(- p)%F
+          | _ => constr:((- p)%F)
         end
     | (/ ?X1) =>
       let p := rew_term X1 in
-        match constr:p with
+        match constr:(p) with
           | (fct_cte ?X2) => constr:(fct_cte (/ X2))
-          | _ => constr:(/ p)%F
+          | _ => constr:((/ p)%F)
         end
-    | (?X1 AppVar) => constr:X1
+    | (?X1 AppVar) => constr:(X1)
     | (?X1 ?X2) =>
       let p := rew_term X2 in
-        match constr:p with
+        match constr:(p) with
           | (fct_cte ?X3) => constr:(fct_cte (X1 X3))
           | _ => constr:(comp X1 p)
         end
-    | AppVar => constr:id
+    | AppVar => constr:(id)
     | (AppVar ^ ?X1) => constr:(pow_fct X1)
     | (?X1 ^ ?X2) =>
       let p := rew_term X1 in
-        match constr:p with
+        match constr:(p) with
           | (fct_cte ?X3) => constr:(fct_cte (pow_fct X2 X3))
           | _ => constr:(comp (pow_fct X2) p)
         end
@@ -669,7 +678,7 @@ Ltac rew_term trm :=
 
 (**********)
 Ltac deriv_proof trm pt :=
-  match constr:trm with
+  match constr:(trm) with
     | (?X1 + ?X2)%F =>
       let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
         constr:(derivable_pt_plus X1 X2 pt p1 p2)
@@ -684,14 +693,14 @@ Ltac deriv_proof trm pt :=
         | id:(?X2 pt <> 0) |- _ =>
           let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
             constr:(derivable_pt_div X1 X2 pt p1 p2 id)
-        | _ => constr:False
+        | _ => constr:(False)
       end
     | (/ ?X1)%F =>
       match goal with
         | id:(?X1 pt <> 0) |- _ =>
           let p1 := deriv_proof X1 pt in
             constr:(derivable_pt_inv X1 pt p1 id)
-        | _ => constr:False
+        | _ => constr:(False)
       end
     | (comp ?X1 ?X2) =>
       let pt_f1 := eval cbv beta in (X2 pt) in
@@ -710,21 +719,21 @@ Ltac deriv_proof trm pt :=
     | sqrt =>
       match goal with
         | id:(0 < pt) |- _ => constr:(derivable_pt_sqrt pt id)
-        | _ => constr:False
+        | _ => constr:(False)
       end
     | (fct_cte ?X1) => constr:(derivable_pt_const X1 pt)
     | ?X1 =>
-      let aux := constr:X1 in
+      let aux := constr:(X1) in
         match goal with
-          | id:(derivable_pt aux pt) |- _ => constr:id
+          | id:(derivable_pt aux pt) |- _ => constr:(id)
           | id:(derivable aux) |- _ => constr:(id pt)
-          | _ => constr:False
+          | _ => constr:(False)
         end
   end.
 
 (**********)
 Ltac simplify_derive trm pt :=
-  match constr:trm with
+  match constr:(trm) with
     | (?X1 + ?X2)%F =>
       try rewrite derive_pt_plus; simplify_derive X1 pt;
         simplify_derive X2 pt
@@ -753,7 +762,7 @@ Ltac simplify_derive trm pt :=
     | Rsqr => try rewrite derive_pt_Rsqr
     | sqrt => try rewrite derive_pt_sqrt
     | ?X1 =>
-      let aux := constr:X1 in
+      let aux := constr:(X1) in
         match goal with
           | id:(derive_pt aux pt ?X2 = _),H:(derivable aux) |- _ =>
             try replace (derive_pt aux pt (H pt)) with (derive_pt aux pt X2);
diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v
index 9d55e4e6..9fbda92a 100644
--- a/theories/Reals/Raxioms.v
+++ b/theories/Reals/Raxioms.v
@@ -32,7 +32,7 @@ Hint Resolve Rplus_assoc: real.
 
 (**********)
 Axiom Rplus_opp_r : forall r:R, r + - r = 0.
-Hint Resolve Rplus_opp_r: real v62.
+Hint Resolve Rplus_opp_r: real.
 
 (**********)
 Axiom Rplus_0_l : forall r:R, 0 + r = r.
@@ -44,11 +44,11 @@ Hint Resolve Rplus_0_l: real.
 
 (**********)
 Axiom Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1.
-Hint Resolve Rmult_comm: real v62.
+Hint Resolve Rmult_comm: real.
 
 (**********)
 Axiom Rmult_assoc : forall r1 r2 r3:R, r1 * r2 * r3 = r1 * (r2 * r3).
-Hint Resolve Rmult_assoc: real v62.
+Hint Resolve Rmult_assoc: real.
 
 (**********)
 Axiom Rinv_l : forall r:R, r <> 0 -> / r * r = 1.
@@ -69,7 +69,7 @@ Hint Resolve R1_neq_R0: real.
 (**********)
 Axiom
   Rmult_plus_distr_l : forall r1 r2 r3:R, r1 * (r2 + r3) = r1 * r2 + r1 * r3.
-Hint Resolve Rmult_plus_distr_l: real v62.
+Hint Resolve Rmult_plus_distr_l: real.
 
 (*********************************************************)
 (** *    Order axioms                                    *)
diff --git a/theories/Reals/Sqrt_reg.v b/theories/Reals/Sqrt_reg.v
index 10527442..d43baee8 100644
--- a/theories/Reals/Sqrt_reg.v
+++ b/theories/Reals/Sqrt_reg.v
@@ -339,7 +339,7 @@ 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.
-  destruct (Rcase_abs x0) as [Hlt|Hgt]_eqn:Heqs.
+  destruct (Rcase_abs x0) as [Hlt|Hgt] eqn:Heqs.
   unfold sqrt. rewrite Heqs.
   rewrite Rabs_R0; apply H2.
   rewrite Rabs_right.
diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v
index 220cebea..fe8a96ac 100644
--- a/theories/Relations/Operators_Properties.v
+++ b/theories/Relations/Operators_Properties.v
@@ -36,7 +36,7 @@ Section Properties.
   Section Clos_Refl_Trans.
 
     Local Notation "R *" := (clos_refl_trans R)
-      (at level 8, left associativity, format "R *").
+      (at level 8, no associativity, format "R *").
 
     (** Correctness of the reflexive-transitive closure operator *)
 
diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v
index b6005b9d..9c98879c 100644
--- a/theories/Relations/Relation_Definitions.v
+++ b/theories/Relations/Relation_Definitions.v
@@ -66,10 +66,10 @@ Section Relation_Definition.
 
 End Relation_Definition.
 
-Hint Unfold reflexive transitive antisymmetric symmetric: sets v62.
+Hint Unfold reflexive transitive antisymmetric symmetric: sets.
 
 Hint Resolve Build_preorder Build_order Build_equivalence Build_PER
   preord_refl preord_trans ord_refl ord_trans ord_antisym equiv_refl
-  equiv_trans equiv_sym per_sym per_trans: sets v62.
+  equiv_trans equiv_sym per_sym per_trans: sets.
 
-Hint Unfold inclusion same_relation commut: sets v62.
+Hint Unfold inclusion same_relation commut: sets.
diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v
index ffd682d6..88239475 100644
--- a/theories/Relations/Relation_Operators.v
+++ b/theories/Relations/Relation_Operators.v
@@ -226,9 +226,9 @@ Section Lexicographic_Exponentiation.
 
 End Lexicographic_Exponentiation.
 
-Hint Unfold transp union: sets v62.
-Hint Resolve t_step rt_step rt_refl rst_step rst_refl: sets v62.
-Hint Immediate rst_sym: sets v62.
+Hint Unfold transp union: sets.
+Hint Resolve t_step rt_step rt_refl rst_step rst_refl: sets.
+Hint Immediate rst_sym: sets.
 
 (* begin hide *)
 (* Compatibility *)
diff --git a/theories/Sets/Classical_sets.v b/theories/Sets/Classical_sets.v
index 8a4bb9f4..837437a2 100644
--- a/theories/Sets/Classical_sets.v
+++ b/theories/Sets/Classical_sets.v
@@ -122,4 +122,4 @@ Section Ensembles_classical.
 End Ensembles_classical.
 
  Hint Resolve Strict_super_set_contains_new_element Subtract_intro
-  not_SIncl_empty: sets v62.
+  not_SIncl_empty: sets.
diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v
index 8d2344f9..6291248e 100644
--- a/theories/Sets/Constructive_sets.v
+++ b/theories/Sets/Constructive_sets.v
@@ -141,4 +141,4 @@ End Ensembles_facts.
 Hint Resolve Singleton_inv Singleton_intro Add_intro1 Add_intro2
   Intersection_inv Couple_inv Setminus_intro Strict_Included_intro
   Strict_Included_strict Noone_in_empty Inhabited_not_empty Add_not_Empty
-  not_Empty_Add Inhabited_add Included_Empty: sets v62.
+  not_Empty_Add Inhabited_add Included_Empty: sets.
diff --git a/theories/Sets/Ensembles.v b/theories/Sets/Ensembles.v
index 8f579214..0fefb354 100644
--- a/theories/Sets/Ensembles.v
+++ b/theories/Sets/Ensembles.v
@@ -90,9 +90,8 @@ Section Ensembles.
 
 End Ensembles.
 
-Hint Unfold In Included Same_set Strict_Included Add Setminus Subtract: sets
-  v62.
+Hint Unfold In Included Same_set Strict_Included Add Setminus Subtract: sets.
 
 Hint Resolve Union_introl Union_intror Intersection_intro In_singleton
   Couple_l Couple_r Triple_l Triple_m Triple_r Disjoint_intro
-  Extensionality_Ensembles: sets v62.
+  Extensionality_Ensembles: sets.
diff --git a/theories/Sets/Finite_sets.v b/theories/Sets/Finite_sets.v
index f38dd6fd..edbc1efe 100644
--- a/theories/Sets/Finite_sets.v
+++ b/theories/Sets/Finite_sets.v
@@ -43,8 +43,8 @@ Section Ensembles_finis.
 
 End Ensembles_finis.
 
-Hint Resolve Empty_is_finite Union_is_finite: sets v62.
-Hint Resolve card_empty card_add: sets v62.
+Hint Resolve Empty_is_finite Union_is_finite: sets.
+Hint Resolve card_empty card_add: sets.
 
 Require Import Constructive_sets.
 
diff --git a/theories/Sets/Image.v b/theories/Sets/Image.v
index 34ea857d..e74ef41e 100644
--- a/theories/Sets/Image.v
+++ b/theories/Sets/Image.v
@@ -200,4 +200,4 @@ Section Image.
 
 End Image.
 
-Hint Resolve Im_def image_empty finite_image: sets v62.
+Hint Resolve Im_def image_empty finite_image: sets.
diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v
index ec38b892..42d0c76d 100644
--- a/theories/Sets/Multiset.v
+++ b/theories/Sets/Multiset.v
@@ -187,7 +187,7 @@ End multiset_defs.
 
 Unset Implicit Arguments.
 
-Hint Unfold meq multiplicity: v62 datatypes.
+Hint Unfold meq multiplicity: datatypes.
 Hint Resolve munion_empty_right munion_comm munion_ass meq_left meq_right
-  munion_empty_left: v62 datatypes.
-Hint Immediate meq_sym: v62 datatypes.
+  munion_empty_left: datatypes.
+Hint Immediate meq_sym: datatypes.
diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v
index 3610ebce..335fec5b 100644
--- a/theories/Sets/Partial_Order.v
+++ b/theories/Sets/Partial_Order.v
@@ -51,8 +51,8 @@ Section Partial_orders.
 
 End Partial_orders.
 
-Hint Unfold Carrier_of Rel_of Strict_Rel_of: sets v62.
-Hint Resolve Definition_of_covers: sets v62.
+Hint Unfold Carrier_of Rel_of Strict_Rel_of: sets.
+Hint Resolve Definition_of_covers: sets.
 
 
 Section Partial_order_facts.
diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v
index d636e046..7c2435da 100644
--- a/theories/Sets/Powerset.v
+++ b/theories/Sets/Powerset.v
@@ -175,14 +175,14 @@ Qed.
 
 End The_power_set_partial_order.
 
-Hint Resolve Empty_set_minimal: sets v62.
-Hint Resolve Power_set_Inhabited: sets v62.
-Hint Resolve Inclusion_is_an_order: sets v62.
-Hint Resolve Inclusion_is_transitive: sets v62.
-Hint Resolve Union_minimal: sets v62.
-Hint Resolve Union_increases_l: sets v62.
-Hint Resolve Union_increases_r: sets v62.
-Hint Resolve Intersection_decreases_l: sets v62.
-Hint Resolve Intersection_decreases_r: sets v62.
-Hint Resolve Empty_set_is_Bottom: sets v62.
-Hint Resolve Strict_inclusion_is_transitive: sets v62.
+Hint Resolve Empty_set_minimal: sets.
+Hint Resolve Power_set_Inhabited: sets.
+Hint Resolve Inclusion_is_an_order: sets.
+Hint Resolve Inclusion_is_transitive: sets.
+Hint Resolve Union_minimal: sets.
+Hint Resolve Union_increases_l: sets.
+Hint Resolve Union_increases_r: sets.
+Hint Resolve Intersection_decreases_l: sets.
+Hint Resolve Intersection_decreases_r: sets.
+Hint Resolve Empty_set_is_Bottom: sets.
+Hint Resolve Strict_inclusion_is_transitive: sets.
diff --git a/theories/Sets/Powerset_Classical_facts.v b/theories/Sets/Powerset_Classical_facts.v
index 09c90506..e802beac 100644
--- a/theories/Sets/Powerset_Classical_facts.v
+++ b/theories/Sets/Powerset_Classical_facts.v
@@ -90,7 +90,7 @@ Section Sets_as_an_algebra.
     apply Subtract_intro; auto with sets.
     red; intro H'1; apply H'; rewrite H'1; auto with sets.
   Qed.
-  Hint Resolve incl_soustr_add_r: sets v62.
+  Hint Resolve incl_soustr_add_r: sets.
 
   Lemma add_soustr_2 :
     forall (X:Ensemble U) (x:U),
@@ -328,9 +328,9 @@ Section Sets_as_an_algebra.
 
 End Sets_as_an_algebra.
 
-Hint Resolve incl_soustr_in: sets v62.
-Hint Resolve incl_soustr: sets v62.
-Hint Resolve incl_soustr_add_l: sets v62.
-Hint Resolve incl_soustr_add_r: sets v62.
-Hint Resolve add_soustr_1 add_soustr_2: sets v62.
-Hint Resolve add_soustr_xy: sets v62.
+Hint Resolve incl_soustr_in: sets.
+Hint Resolve incl_soustr: sets.
+Hint Resolve incl_soustr_add_l: sets.
+Hint Resolve incl_soustr_add_r: sets.
+Hint Resolve add_soustr_1 add_soustr_2: sets.
+Hint Resolve add_soustr_xy: sets.
diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v
index 63e84199..e9696a1c 100644
--- a/theories/Sets/Powerset_facts.v
+++ b/theories/Sets/Powerset_facts.v
@@ -254,5 +254,5 @@ Section Sets_as_an_algebra.
 End Sets_as_an_algebra.
 
 Hint Resolve Empty_set_zero Empty_set_zero' Union_associative Union_add
-  singlx incl_add: sets v62.
+  singlx incl_add: sets.
 
diff --git a/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v
index de96fa56..45fb8134 100644
--- a/theories/Sets/Relations_1.v
+++ b/theories/Sets/Relations_1.v
@@ -60,6 +60,6 @@ Section Relations_1.
 
 End Relations_1.
 Hint Unfold Reflexive Transitive Antisymmetric Symmetric contains
-  same_relation: sets v62.
+  same_relation: sets.
 Hint Resolve Definition_of_preorder Definition_of_order
-  Definition_of_equivalence Definition_of_PER: sets v62.
+  Definition_of_equivalence Definition_of_PER: sets.
diff --git a/theories/Sets/Relations_2.v b/theories/Sets/Relations_2.v
index f1026e31..1e0b83fe 100644
--- a/theories/Sets/Relations_2.v
+++ b/theories/Sets/Relations_2.v
@@ -48,7 +48,7 @@ Definition Strongly_confluent : Prop :=
 
 End Relations_2.
 
-Hint Resolve Rstar_0: sets v62.
-Hint Resolve Rstar1_0: sets v62.
-Hint Resolve Rstar1_1: sets v62.
-Hint Resolve Rplus_0: sets v62.
+Hint Resolve Rstar_0: sets.
+Hint Resolve Rstar1_0: sets.
+Hint Resolve Rstar1_1: sets.
+Hint Resolve Rplus_0: sets.
diff --git a/theories/Sets/Relations_3.v b/theories/Sets/Relations_3.v
index 92b29988..c05b5ee7 100644
--- a/theories/Sets/Relations_3.v
+++ b/theories/Sets/Relations_3.v
@@ -51,10 +51,10 @@ Section Relations_3.
    Definition Noetherian : Prop := forall x:U, noetherian x.
 
 End Relations_3.
-Hint Unfold coherent: sets v62.
-Hint Unfold locally_confluent: sets v62.
-Hint Unfold confluent: sets v62.
-Hint Unfold Confluent: sets v62.
-Hint Resolve definition_of_noetherian: sets v62.
-Hint Unfold Noetherian: sets v62.
+Hint Unfold coherent: sets.
+Hint Unfold locally_confluent: sets.
+Hint Unfold confluent: sets.
+Hint Unfold Confluent: sets.
+Hint Resolve definition_of_noetherian: sets.
+Hint Unfold Noetherian: sets.
 
diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v
index e159efa8..44f8ff6a 100644
--- a/theories/Sorting/Permutation.v
+++ b/theories/Sorting/Permutation.v
@@ -318,10 +318,10 @@ Lemma Permutation_length_2_inv :
 Proof.
   intros a1 a2 l H; remember [a1;a2] as m in H.
   revert a1 a2 Heqm.
-  induction H; intros; try (injection Heqm; intros; subst; clear Heqm);
+  induction H; intros; try (injection Heqm as ? ?; subst);
     discriminate || (try tauto).
   apply Permutation_length_1_inv in H as ->; left; auto.
-  apply IHPermutation1 in Heqm as [H1|H1]; apply IHPermutation2 in H1 as ();
+  apply IHPermutation1 in Heqm as [H1|H1]; apply IHPermutation2 in H1 as [];
     auto.
 Qed.
 
diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v
index 97cb746f..55a533c5 100644
--- a/theories/Strings/Ascii.v
+++ b/theories/Strings/Ascii.v
@@ -40,7 +40,7 @@ Defined.
 
 (** * Conversion between natural numbers modulo 256 and ascii characters *)
 
-(** Auxillary function that turns a positive into an ascii by
+(** Auxiliary function that turns a positive into an ascii by
    looking at the last 8 bits, ie z mod 2^8 *)
 
 Definition ascii_of_pos : positive -> ascii :=
diff --git a/theories/Strings/String.v b/theories/Strings/String.v
index 943bb48e..451b65cb 100644
--- a/theories/Strings/String.v
+++ b/theories/Strings/String.v
@@ -83,7 +83,7 @@ intros H; generalize (H 0); simpl; intros H1; inversion H1.
 case (Rec s).
 intros H0; rewrite H0; auto.
 intros n; exact (H (S n)).
-intros H; injection H; intros H1 H2 n; case n; auto.
+intros H; injection H as H1 H2.
 rewrite H2; trivial.
 rewrite H1; auto.
 Qed.
@@ -238,14 +238,14 @@ intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl;
  auto.
 intros n; case n; simpl; auto.
 intros m s1; case s1; simpl; auto.
-intros H; injection H; intros H1; rewrite <- H1; auto.
+intros H; injection H as <-; auto.
 intros; discriminate.
 intros; discriminate.
 intros b s2' Rec n m s1.
 case n; simpl; auto.
 generalize (prefix_correct s1 (String b s2'));
  case (prefix s1 (String b s2')).
-intros H0 H; injection H; intros H1; rewrite <- H1; auto.
+intros H0 H; injection H as <-; auto.
 case H0; simpl; auto.
 case m; simpl; auto.
 case (index 0 s1 s2'); intros; discriminate.
@@ -271,7 +271,7 @@ intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl;
  auto.
 intros n; case n; simpl; auto.
 intros m s1; case s1; simpl; auto.
-intros H; injection H; intros H1; rewrite <- H1.
+intros H; injection H as <-.
 intros p H0 H2; inversion H2.
 intros; discriminate.
 intros; discriminate.
@@ -279,7 +279,7 @@ intros b s2' Rec n m s1.
 case n; simpl; auto.
 generalize (prefix_correct s1 (String b s2'));
  case (prefix s1 (String b s2')).
-intros H0 H; injection H; intros H1; rewrite <- H1; auto.
+intros H0 H; injection H as <-; auto.
 intros p H2 H3; inversion H3.
 case m; simpl; auto.
 case (index 0 s1 s2'); intros; discriminate.
diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v
index 954d3df2..0115d8a5 100644
--- a/theories/Structures/OrdersFacts.v
+++ b/theories/Structures/OrdersFacts.v
@@ -434,21 +434,21 @@ Lemma eqb_compare x y :
  (x =? y) = match compare x y with Eq => true | _ => false end.
 Proof.
 apply eq_true_iff_eq. rewrite eqb_eq, <- compare_eq_iff.
-destruct compare; now split.
+now destruct compare.
 Qed.
 
 Lemma ltb_compare x y :
  (x <? y) = match compare x y with Lt => true | _ => false end.
 Proof.
 apply eq_true_iff_eq. rewrite ltb_lt, <- compare_lt_iff.
-destruct compare; now split.
+now destruct compare.
 Qed.
 
 Lemma leb_compare x y :
  (x <=? y) = match compare x y with Gt => false | _ => true end.
 Proof.
 apply eq_true_iff_eq. rewrite leb_le, <- compare_le_iff.
-destruct compare; split; try easy. now destruct 1.
+now destruct compare.
 Qed.
 
 End BoolOrderFacts.
diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v
index 45c13e5c..1f8b76cb 100644
--- a/theories/Vectors/VectorDef.v
+++ b/theories/Vectors/VectorDef.v
@@ -30,7 +30,7 @@ Inductive t A : nat -> Type :=
   |nil : t A 0
   |cons : forall (h:A) (n:nat), t A n -> t A (S n).
 
-Local Notation "[]" := (nil _).
+Local Notation "[ ]" := (nil _) (format "[ ]").
 Local Notation "h :: t" := (cons _ h _ t) (at level 60, right associativity).
 
 Section SCHEMES.
@@ -102,7 +102,7 @@ Definition const {A} (a:A) := nat_rect _ [] (fun n x => cons _ a n x).
 
 Computational behavior of this function should be the same as
 ocaml function. *)
-Definition nth {A} := 
+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 => caseS (fun n v' => A) (fun h n t => h)
@@ -293,12 +293,14 @@ Eval cbv delta beta in fold_right (fun h H => Datatypes.cons h H) v Datatypes.ni
 End VECTORLIST.
 
 Module VectorNotations.
-Notation "[]" := [] : vector_scope.
+Delimit Scope vector_scope with vector.
+Notation "[ ]" := [] (format "[ ]") : vector_scope.
+Notation "[]" := [] (compat "8.5") : vector_scope.
 Notation "h :: t" := (h :: t) (at level 60, right associativity)
   : vector_scope.
-Notation " [ x ] " := (x :: []) : vector_scope.
-Notation " [ x ; .. ; y ] " := (cons _ x _ .. (cons _ y _ (nil _)) ..) : vector_scope
-.
+Notation "[ x ]" := (x :: []) : vector_scope.
+Notation "[ x ; y ; .. ; z ]" := (cons _ x _ (cons _ y _ .. (cons _ z _ (nil _)) ..)) : vector_scope.
+Notation "[ x ; .. ; y ]" := (cons _ x _ .. (cons _ y _ (nil _)) ..) (compat "8.4") : vector_scope.
 Notation "v [@ p ]" := (nth v p) (at level 1, format "v [@ p ]") : vector_scope.
 Open Scope vector_scope.
 End VectorNotations.
diff --git a/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v
index 992263cb..d90f9956 100644
--- a/theories/Wellfounded/Lexicographic_Exponentiation.v
+++ b/theories/Wellfounded/Lexicographic_Exponentiation.v
@@ -75,7 +75,7 @@ Section Wf_Lexicographic_Exponentiation.
   Proof.
     intros.
     inversion H.
-    - apply app_cons_not_nil in H1 as ().
+    - 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.
@@ -98,7 +98,7 @@ Section Wf_Lexicographic_Exponentiation.
       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 ().
+      + 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.
@@ -145,7 +145,7 @@ Section Wf_Lexicographic_Exponentiation.
           pose proof H0 as H0'.
           apply app_inj_tail in H0' as (_, ->).
           rewrite app_assoc_reverse in H0.
-          apply Hind in H0 as ().
+          apply Hind in H0 as [].
           split.
           assumption.
           apply d_conc; auto with sets.
diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v
index 4b8447f4..b2ada2f9 100644
--- a/theories/Wellfounded/Lexicographic_Product.v
+++ b/theories/Wellfounded/Lexicographic_Product.v
@@ -44,14 +44,11 @@ Section WfLexicographic_Product.
     apply H2.
     auto with sets.
 
-    injection H1.
-    destruct 2.
-    injection H3.
-    destruct 2; auto with sets.
+    injection H1 as <- _.
+    injection H3 as <- _; auto with sets.
 
     rewrite <- H1.
-    injection H3; intros _ Hx1.
-    subst x1.
+    injection H3 as -> H3.
     apply IHAcc0.
     elim inj_pair2 with A B x y' x0; assumption.
   Defined.
diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v
index d210792f..72021f2e 100644
--- a/theories/ZArith/Int.v
+++ b/theories/ZArith/Int.v
@@ -225,11 +225,11 @@ Module MoreInt (Import I:Int).
   (** [int] to [ExprI] *)
 
   Ltac i2ei trm :=
-    match constr:trm with
-      | 0 => constr:EI0
-      | 1 => constr:EI1
-      | 2 => constr:EI2
-      | 3 => constr:EI3
+    match constr:(trm) with
+      | 0 => constr:(EI0)
+      | 1 => constr:(EI1)
+      | 2 => constr:(EI2)
+      | 3 => constr:(EI3)
       | ?x + ?y => let ex := i2ei x with ey := i2ei y in constr:(EIadd ex ey)
       | ?x - ?y => let ex := i2ei x with ey := i2ei y in constr:(EIsub ex ey)
       | ?x * ?y => let ex := i2ei x with ey := i2ei y in constr:(EImul ex ey)
@@ -241,7 +241,7 @@ Module MoreInt (Import I:Int).
   (** [Z] to [ExprZ] *)
 
     with z2ez trm :=
-    match constr:trm with
+    match constr:(trm) with
       | (?x + ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZadd ex ey)
       | (?x - ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZsub ex ey)
       | (?x * ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmul ex ey)
@@ -254,7 +254,7 @@ Module MoreInt (Import I:Int).
   (** [Prop] to [ExprP] *)
 
   Ltac p2ep trm :=
-    match constr:trm with
+    match constr:(trm) with
       | (?x <-> ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPequiv ex ey)
       | (?x -> ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPimpl ex ey)
       | (?x /\ ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPand ex ey)
@@ -451,4 +451,8 @@ Module Z_as_Int <: Int.
   Lemma i2z_ltb n p : ltb n p = Z.ltb (i2z n) (i2z p).
   Proof. reflexivity. Qed.
 
+  (** Compatibility notations for Coq v8.4 *)
+  Notation plus := add (compat "8.4").
+  Notation minus := sub (compat "8.4").
+  Notation mult := mul (compat "8.4").
 End Z_as_Int.
diff --git a/theories/ZArith/Zsqrt_compat.v b/theories/ZArith/Zsqrt_compat.v
index b80eb445..f4baba19 100644
--- a/theories/ZArith/Zsqrt_compat.v
+++ b/theories/ZArith/Zsqrt_compat.v
@@ -30,12 +30,12 @@ Local Open Scope Z_scope.
 Ltac compute_POS :=
   match goal with
     |  |- context [(Zpos (xI ?X1))] =>
-      match constr:X1 with
+      match constr:(X1) with
 	| context [1%positive] => fail 1
 	| _ => rewrite (Pos2Z.inj_xI X1)
       end
     |  |- context [(Zpos (xO ?X1))] =>
-      match constr:X1 with
+      match constr:(X1) with
 	| context [1%positive] => fail 1
 	| _ => rewrite (Pos2Z.inj_xO X1)
       end
diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v
index 1ac00bdd..90754af3 100644
--- a/theories/ZArith/Zwf.v
+++ b/theories/ZArith/Zwf.v
@@ -56,7 +56,7 @@ Section wf_proof.
 
 End wf_proof.
 
-Hint Resolve Zwf_well_founded: datatypes v62.
+Hint Resolve Zwf_well_founded: datatypes.
 
 
 (** We also define the other family of relations:
@@ -88,4 +88,4 @@ Section wf_proof_up.
 
 End wf_proof_up.
 
-Hint Resolve Zwf_up_well_founded: datatypes v62.
+Hint Resolve Zwf_up_well_founded: datatypes.
diff --git a/theories/theories.itarget b/theories/theories.itarget
deleted file mode 100644
index aacab2d9..00000000
--- a/theories/theories.itarget
+++ /dev/null
@@ -1,25 +0,0 @@
-Arith/vo.otarget
-Bool/vo.otarget
-Classes/vo.otarget
-Compat/vo.otarget
-FSets/vo.otarget
-MSets/vo.otarget
-Structures/vo.otarget
-Init/vo.otarget
-Lists/vo.otarget
-Vectors/vo.otarget
-Logic/vo.otarget
-PArith/vo.otarget
-NArith/vo.otarget
-Numbers/vo.otarget
-Program/vo.otarget
-QArith/vo.otarget
-Reals/vo.otarget
-Relations/vo.otarget
-Setoids/vo.otarget
-Sets/vo.otarget
-Sorting/vo.otarget
-Strings/vo.otarget
-Unicode/vo.otarget
-Wellfounded/vo.otarget
-ZArith/vo.otarget
diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml
index 478cf887..eab909f5 100644
--- a/tools/coq_makefile.ml
+++ b/tools/coq_makefile.ml
@@ -27,8 +27,9 @@ let rec print_list sep = function
   | x :: l -> print x; print sep; print_list sep l
   | [] -> ()
 
-let list_iter_i f =
-  let rec aux i = function [] -> () | a::l -> f i a; aux (i+1) l in aux 1
+let rec print_prefix_list sep = function
+  | x :: l -> print sep; print x; print_prefix_list sep l
+  | [] -> ()
 
 let section s =
   let l = String.length s in
@@ -43,6 +44,17 @@ let section s =
   print_com (String.make (l+2) '#');
   print "\n"
 
+(* These are the Coq library directories that are used for
+ * plugin development
+ *)
+let lib_dirs =
+  ["kernel"; "lib"; "library"; "parsing";
+   "pretyping"; "interp"; "printing"; "intf";
+   "proofs"; "tactics"; "tools"; "ltacprof";
+   "toplevel"; "stm"; "grammar"; "config";
+   "ltac"; "engine"]
+
+
 let usage () =
   output_string stderr "Usage summary:
 
@@ -93,17 +105,28 @@ let is_genrule r = (* generic rule (like bar%foo: ...) *)
       Str.string_match genrule r 0
 
 let string_prefix a b =
-  let rec aux i = try if a.[i] = b.[i] then aux (i+1) else i with |Invalid_argument _ -> i in
-    String.sub a 0 (aux 0)
+  let rec aux i =
+    try if a.[i] = b.[i] then aux (i+1) else i with Invalid_argument _ -> i
+  in
+  String.sub a 0 (aux 0)
 
 let is_prefix dir1 dir2 =
   let l1 = String.length dir1 in
   let l2 = String.length dir2 in
-    dir1 = dir2 || (l1 < l2 && String.sub dir2 0 l1 = dir1 && dir2.[l1] = '/')
+  let sep = Filename.dir_sep in
+  if dir1 = dir2 then true
+  else if l1 + String.length sep <= l2 then
+    let dir1' = String.sub dir2 0 l1 in
+    let sep' = String.sub dir2 l1 (String.length sep) in
+    dir1' = dir1 && sep' = sep
+  else false
 
 let physical_dir_of_logical_dir ldir =
   let le = String.length ldir - 1 in
-  let pdir = if le >= 0 && 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;
@@ -118,62 +141,74 @@ let standard opt =
   print "\"\n\n"
 
 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
+  if List.exists (fun (pdir,_,_) -> pdir = ".") inc_r ||
+     List.exists (fun (pdir,_,_) -> pdir = ".") inc_i
+  then ()
+  else
+    let absdir_of_files =List.rev_map
 	(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_ml in
-	if has_inc_i then
-	  begin
-	    printf "%sINC=" var;
-	    List.iter (fun (pdir,absdir) ->
-			 if List.mem absdir absdir_of_files
-			 then printf
-			   "$(filter $(wildcard %s/*),$(%s)) "
-			   pdir var
-		      ) inc_ml;
-	    printf "\n";
-	  end;
-      (* Files in the scope of a -R option (assuming they are disjoint) *)
-	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_i@inc_r);
-    end
+	files
+    in
+    (* files in scope of a -I option (assuming they are no overlapping) *)
+    if List.exists (fun (_,a) -> List.mem a absdir_of_files) inc_ml then
+      begin
+	printf "%sINC=" var;
+	List.iter (fun (pdir,absdir) ->
+		   if List.mem absdir absdir_of_files
+		   then printf "$(filter $(wildcard %s/*),$(%s)) " pdir var)
+		  inc_ml;
+	printf "\n";
+      end;
+    (* Files in the scope of a -R option (assuming they are disjoint) *)
+    List.iteri (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_i@inc_r)
 
 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 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) *)
   match inc_i@inc_r with
-  |[(".",t,_)] -> (None,[".",physical_dir_of_logical_dir t,List.rev_map fst var_x_files_l])
+  |[(".",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\n" in
+      let () = prerr_string "Warning: install rule assumes that -R/-Q . _ is the only -R/-Q option\n"
+      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)),
+      let varq = var_filter
+                   (fun l -> List.exists (fun (_,a) -> List.mem a l) inc_ml)
+                   (fun x -> x)
+      in
       (* (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 other =
+        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) 0 [] l
+      in (Some varq, other)
 
 let install_include_by_root perms =
   let install_dir for_i (pdir,pdir',vars) =
@@ -249,33 +284,38 @@ let where_put_doc = function
  install-doc will put anything in $INSTALLDEFAULTROOT\n" in
 	"$(INSTALLDEFAULTROOT)"
 
-let install (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,sds) inc = function
+let install (vfiles,(mlis,ml4s,mls,mllibs,mlpacks),_,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 cmos = List.rev_append mlpacks (List.rev_append mls ml4s) in
+    let cmis = List.rev_append mlis cmos in
+    let cmxss = List.rev_append cmos mllibs in
+    let where_what_cmxs = vars_to_put_by_root [("CMXSFILES",cmxss)] 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)]
+      [("VOFILES",vfiles);("VFILES",vfiles);
+       ("GLOBFILES",vfiles);("NATIVEFILES",vfiles);
+       ("CMOFILES",cmos);("CMIFILES",cmis);("CMAFILES",mllibs)]
       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
-    if (not_empty cmxsfiles) then begin
+    if is_install = Project_file.UnspecInstall then begin
+	print "userinstall:\n\t+$(MAKE) USERINSTALL=true install\n\n"
+    end;
+    if not_empty cmxss then begin
       print "install-natdynlink:\n";
       install_include_by_root "0755" where_what_cmxs;
       print "\n";
     end;
-    if (not_empty cmxsfiles) then begin
+    if not_empty cmxss 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)";
+    if not_empty cmxss then begin
+      print "$(if $(HASNATDYNLINK_OR_EMPTY),install-natdynlink)";
+    end;
     print "\n";
     install_include_by_root "0644" where_what_oth;
     List.iter
@@ -290,7 +330,7 @@ let install (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,sds) in
       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;
+    if not_empty mlis then install_one_kind "mlihtml" doc_dir;
     print "\n";
     let uninstall_one_kind kind dir =
       printf "\tprintf 'cd \"$${DSTROOT}\"$(COQDOCINSTALL)/%s \\\\\\n' >> \"$@\"\n" dir;
@@ -300,10 +340,10 @@ let install (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,sds) in
     in
     printf "uninstall_me.sh: %s\n" !makefile_name;
     print "\techo '#!/bin/sh' > $@\n";
-    if (not_empty cmxsfiles) then uninstall_by_root where_what_cmxs;
+    if not_empty cmxss 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;
+    if not_empty mlis then uninstall_one_kind "mlihtml" doc_dir;
     print "\tchmod +x $@\n";
     print "\n";
     print "uninstall: uninstall_me.sh\n";
@@ -322,11 +362,14 @@ let make_makefile sds =
 
 let clean sds sps =
   print "clean::\n";
-  if !some_mlfile || !some_mlifile || !some_ml4file || !some_mllibfile || !some_mlpackfile then begin
-    print "\trm -f $(ALLCMOFILES) $(CMIFILES) $(CMAFILES)\n";
-    print "\trm -f $(ALLCMOFILES:.cmo=.cmx) $(CMXAFILES) $(CMXSFILES) $(ALLCMOFILES:.cmo=.o) $(CMXAFILES:.cmxa=.a)\n";
-    print "\trm -f $(addsuffix .d,$(MLFILES) $(MLIFILES) $(ML4FILES) $(MLLIBFILES) $(MLPACKFILES))\n";
-  end;
+  if !some_mlfile || !some_mlifile || !some_ml4file
+     || !some_mllibfile || !some_mlpackfile
+  then
+    begin
+      print "\trm -f $(ALLCMOFILES) $(CMIFILES) $(CMAFILES)\n";
+      print "\trm -f $(ALLCMOFILES:.cmo=.cmx) $(CMXAFILES) $(CMXSFILES) $(ALLCMOFILES:.cmo=.o) $(CMXAFILES:.cmxa=.a)\n";
+      print "\trm -f $(addsuffix .d,$(MLFILES) $(MLIFILES) $(ML4FILES) $(MLLIBFILES) $(MLPACKFILES))\n";
+    end;
   if !some_vfile then
     begin
       print "\trm -f $(OBJFILES) $(OBJFILES:.o=.native) $(NATIVEFILES)\n";
@@ -355,7 +398,7 @@ let clean sds sps =
     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 'OCAMLFIND =\t$(OCAMLFIND)'\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 () = ()
@@ -363,48 +406,78 @@ let header_includes () = ()
 let implicit () =
     section "Implicit rules.";
   let mli_rules () =
-    print "$(MLIFILES:.mli=.cmi): %.cmi: %.mli\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
+    print "$(MLIFILES:.mli=.cmi): %.cmi: %.mli\n";
+    print "\t$(SHOW)'CAMLC -c $<'\n";
+    print "\t$(HIDE)$(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
+    print "\t$(SHOW)'CAMLDEP $<'\n";
+    print "\t$(HIDE)$(CAMLDEP) $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n"
+  in
   let ml4_rules () =
-    print "$(ML4FILES:.ml4=.cmo): %.cmo: %.ml4\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n";
+    print "$(ML4FILES:.ml4=.cmo): %.cmo: %.ml4\n";
+    print "\t$(SHOW)'CAMLC -pp -c $<'\n";
+    print "\t$(HIDE)$(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 "\t$(SHOW)'CAMLOPT -pp -c $<'\n";
+    print "\t$(HIDE)$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n";
     print "$(addsuffix .d,$(ML4FILES)): %.ml4.d: %.ml4\n";
-    print "\t$(OCAMLDEP) -slash $(OCAMLLIBS) $(PP) -impl \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
+    print "\t$(SHOW)'CAMLDEP -pp $<'\n";
+    print "\t$(HIDE)$(CAMLDEP) $(OCAMLLIBS) $(PP) -impl \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
   let ml_rules () =
-    print "$(MLFILES:.ml=.cmo): %.cmo: %.ml\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
+    print "$(MLFILES:.ml=.cmo): %.cmo: %.ml\n";
+    print "\t$(SHOW)'CAMLC -c $<'\n";
+    print "\t$(HIDE)$(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 "\t$(SHOW)'CAMLOPT -c $<'\n";
+    print "\t$(HIDE)$(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
+    print "\t$(SHOW)'CAMLDEP $<'\n";
+    print "\t$(HIDE)$(CAMLDEP) $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\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
+    print "$(filter-out $(MLLIBFILES:.mllib=.cmxs),$(MLFILES:.ml=.cmxs) $(ML4FILES:.ml4=.cmxs) $(MLPACKFILES:.mlpack=.cmxs)): %.cmxs: %.cmx\n";
+    print "\t$(SHOW)'CAMLOPT -shared -o $@'\n";
+    print "\t$(HIDE)$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -shared -o $@ $<\n\n";
+    print "$(MLLIBFILES:.mllib=.cmxs): %.cmxs: %.cmxa\n";
+    print "\t$(SHOW)'CAMLOPT -shared -o $@'\n";
+    print "\t$(HIDE)$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -linkall -shared -o $@ $<\n\n"
+  in
   let mllib_rules () =
-    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 "$(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib\n";
+    print "\t$(SHOW)'CAMLC -a -o $@'\n";
+    print "\t$(HIDE)$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n";
+    print "$(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib\n";
+    print "\t$(SHOW)'CAMLOPT -a -o $@'\n";
+    print "\t$(HIDE)$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n";
     print "$(addsuffix .d,$(MLLIBFILES)): %.mllib.d: %.mllib\n";
-    print "\t$(COQDEP) $(OCAMLLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
+    print "\t$(SHOW)'COQDEP $<'\n";
+    print "\t$(HIDE)$(COQDEP) $(OCAMLLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n"
+  in
   let mlpack_rules () =
-    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 "$(MLPACKFILES:.mlpack=.cmo): %.cmo: | %.mlpack\n";
+    print "\t$(SHOW)'CAMLC -pack -o $@'\n";
+    print "\t$(HIDE)$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -pack -o $@ $^\n\n";
+    print "$(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack\n";
+    print "\t$(SHOW)'CAMLOPT -pack -o $@'\n";
+    print "\t$(HIDE)$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -pack -o $@ $^\n\n";
     print "$(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack\n";
-    print "\t$(COQDEP) $(OCAMLLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n";
-in
+    print "\t$(SHOW)'COQDEP $<'\n";
+    print "\t$(HIDE)$(COQDEP) $(OCAMLLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n"
+  in
   let v_rules () =
-    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 "$(VOFILES): %.vo: %.v\n";
+    print "\t$(SHOW)COQC $<\n";
+    print "\t$(HIDE)$(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"
+    print "\t$(SHOW)'COQDEP $<'\n";
+    print "\t$(HIDE)$(COQDEP) $(COQLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n";
+    print "$(addsuffix .beautified,$(VFILES)): %.v.beautified:\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $*.v\n\n"
   in
     if !some_mlifile then mli_rules ();
     if !some_ml4file then ml4_rules ();
@@ -446,26 +519,24 @@ let variables is_install opt (args,defs) =
     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)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\"";
+    print "COQSRCLIBS?=" ;
+    List.iter (fun c -> print "-I \"$(COQLIB)"; print c ; print "\" \\\n") lib_dirs ;
     List.iter (fun c -> print " \\
   -I \"$(COQLIB)/"; print c; print "\"") Coq_config.plugins_dirs; print "\n";
     print "ZFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB)\n\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 "CAMLC?=$(OCAMLFIND) ocamlc -c -rectypes -thread\n";
+    print "CAMLOPTC?=$(OCAMLFIND) opt -c -rectypes -thread\n";
+    print "CAMLLINK?=$(OCAMLFIND) ocamlc -rectypes -thread\n";
+    print "CAMLOPTLINK?=$(OCAMLFIND) opt -rectypes -thread\n";
+    print "CAMLDEP?=$(OCAMLFIND) ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack\n";
+    print "CAMLLIB?=$(shell $(OCAMLFIND) printconf stdlib)\n";
     print "GRAMMARS?=grammar.cma\n";
     print "ifeq ($(CAMLP4),camlp5)
-CAMLP4EXTEND=pa_extend.cmo q_MLast.cmo pa_macro.cmo unix.cma threads.cma
+CAMLP4EXTEND=pa_extend.cmo q_MLast.cmo pa_macro.cmo
 else
-CAMLP4EXTEND=threads.cma
+CAMLP4EXTEND=
 endif\n";
-    print "PP?=-pp '$(CAMLP4O) -I $(CAMLLIB) -I $(CAMLLIB)threads/ $(COQSRCLIBS) compat5.cmo \\
+    print "PP?=-pp '$(CAMLP4O) -I $(CAMLLIB) -I $(COQLIB)/grammar compat5.cmo \\
   $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl'\n\n";
     end;
     match is_install with
@@ -502,39 +573,50 @@ let parameters () =
   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 "# DSTROOT to specify a prefix to install path.\n";
+  print "# VERBOSE to disable the short display of compilation rules.\n\n";
+  print "VERBOSE?=\n";
+  print "SHOW := $(if $(VERBOSE),@true \"\",@echo \"\")\n";
+  print "HIDE := $(if $(VERBOSE),,@)\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";
-  print "TIMED=\nTIMECMD=\nSTDTIME?=/usr/bin/time -f \"$* (user: %U mem: %M ko)\"\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 include_dirs (inc_ml,inc_q,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 includes =
+    List.map (fun (p,l,_) ->
+              let l' = if l = "" then "\"\"" else l in
+              " \"" ^ p ^ "\" " ^ l' ^"") in
   let str_ml = parse_ml_includes inc_ml 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_ml; print "\n";
-    end;
-    if !some_vfile || !some_mllibfile || !some_mlpackfile then begin
-      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
+  section "Libraries definitions.";
+  if !some_ml4file || !some_mlfile || !some_mlifile then begin
+    print "OCAMLLIBS?="; print_list "\\\n  " str_ml; print "\n";
+  end;
+  if !some_vfile || !some_mllibfile || !some_mlpackfile then begin
+    print "COQLIBS?=";
+    print_prefix_list "\\\n  -Q" (includes inc_q);
+    print_prefix_list "\\\n  -R" (includes inc_r);
+    print_prefix_list "\\\n  " str_ml;
+    print "\n";
+  end;
+  if !some_vfile then begin
+    print "COQCHKLIBS?=";
+    print_prefix_list "\\\n  -R" (includes inc_q);
+    print_prefix_list "\\\n  -R" (includes inc_r);
+    print "\n";
+    print "COQDOCLIBS?=";
+    print_prefix_list "\\\n  -R" (includes inc_q);
+    print_prefix_list "\\\n  -R" (includes inc_r);
+    print "\n";
+  end;
+  print "\n"
 
 let double_colon = ["clean"; "cleanall"; "archclean"]
 
@@ -565,10 +647,13 @@ let forpacks l =
   let () = if l <> [] then section "Ad-hoc implicit rules for mlpack." in
   List.iter (fun it ->
     let h = Filename.chop_extension it in
+    let pk = String.capitalize (Filename.basename h) in
     printf "$(addsuffix .cmx,$(filter $(basename $(MLFILES)),$(%s_MLPACK_DEPENDENCIES))): %%.cmx: %%.ml\n" h;
-    printf "\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) -for-pack %s $<\n\n" (String.capitalize (Filename.basename h));
+    printf "\t$(SHOW)'CAMLOPT -c -for-pack %s $<'\n" pk;
+    printf "\t$(HIDE)$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) -for-pack %s $<\n\n" pk;
     printf "$(addsuffix .cmx,$(filter $(basename $(ML4FILES)),$(%s_MLPACK_DEPENDENCIES))): %%.cmx: %%.ml4\n" h;
-    printf "\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) -for-pack %s $(PP) -impl $<\n\n" (String.capitalize (Filename.basename h))
+    printf "\t$(SHOW)'CAMLOPT -c -pp -for-pack %s $<'\n" pk;
+    printf "\t$(HIDE)$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) -for-pack %s $(PP) -impl $<\n\n" pk
   ) l
 
 let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other_targets inc =
@@ -682,9 +767,9 @@ let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other
     begin
       print "mlihtml: $(MLIFILES:.mli=.cmi)\n";
       print "\t mkdir $@ || rm -rf $@/*\n";
-      print "\t$(OCAMLDOC) -html -rectypes -d $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n";
+      print "\t$(OCAMLFIND) ocamldoc -html -rectypes -d $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n";
       print "all-mli.tex: $(MLIFILES:.mli=.cmi)\n";
-      print "\t$(OCAMLDOC) -latex -rectypes -o $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n";
+      print "\t$(OCAMLFIND) ocamldoc -latex -rectypes -o $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n";
     end;
   if !some_vfile then
     begin
@@ -707,7 +792,7 @@ let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other
       print "all-gal.pdf: $(VFILES)\n";
       print "\t$(COQDOC) -toc $(COQDOCFLAGS) -pdf -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n";
       print "validate: $(VOFILES)\n";
-      print "\t$(COQCHK) $(COQCHKFLAGS) $(COQLIBS) $(notdir $(^:.vo=))\n\n";
+      print "\t$(COQCHK) $(COQCHKFLAGS) $(COQCHKLIBS) $(notdir $(^:.vo=))\n\n";
       print "beautify: $(VFILES:=.beautified)\n";
       print "\tfor file in $^; do mv $${file%.beautified} $${file%beautified}old && mv $${file} $${file%.beautified}; done\n";
       print "\t@echo \'Do not do \"make clean\" until you are sure that everything went well!\'\n";
@@ -760,22 +845,24 @@ let command_line args =
   print_list args;
   print "\n#\n\n"
 
-let ensure_root_dir (v,(mli,ml4,ml,mllib,mlpack),_,_) ((ml_inc,i_inc,r_inc) as l) =
+let ensure_root_dir (vfiles,(mlis,ml4s,mls,mllibs,mlpacks),_,_) inc =
+  let (ml_inc,i_inc,r_inc) = inc in
   let here = Sys.getcwd () in
-  let not_tops =List.for_all (fun s -> s <> Filename.basename s) in
+  let not_tops =  List.for_all (fun s -> s <> Filename.basename s) in
   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
+    || (not_tops vfiles && not_tops mlis && not_tops ml4s && not_tops mls
+	&& not_tops mllibs && not_tops mlpacks)
+  then
+    inc
   else
     ((".",here)::ml_inc,i_inc,(".","Top",here)::r_inc)
 
-let warn_install_at_root_directory
-    (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,_) (inc_ml,inc_i,inc_r) =
+let warn_install_at_root_directory (vfiles,(mlis,ml4s,mls,mllibs,mlpacks),_,_) inc =
+  let (inc_ml,inc_i,inc_r) = inc in
   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
+  let files = vfiles @ mlis @ ml4s @ mls @ mllibs @ mlpacks in
   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 or -Q %sis recommended\n"
@@ -793,12 +880,29 @@ let check_overlapping_include (_,inc_i,inc_r) =
 	    Printf.eprintf "Warning: in options -R/-Q, %s and %s overlap\n" pdir pdir') l;
   in aux (inc_i@inc_r)
 
+(* Generate a .merlin file that references the standard library and
+ * any -I included paths.
+ *)
+let merlin targets (ml_inc,_,_) =
+  print ".merlin:\n";
+  print "\t@echo 'FLG -rectypes' > .merlin\n" ;
+  List.iter (fun c ->
+      printf "\t@echo \"B $(COQLIB)%s\" >> .merlin\n" c)
+    lib_dirs ;
+  List.iter (fun (_,c) ->
+      printf "\t@echo \"B %s\" >> .merlin\n" c;
+      printf "\t@echo \"S %s\" >> .merlin\n" c)
+    ml_inc;
+  print "\n"
+
 let do_makefile args =
   let has_file var = function
     |[] -> var := false
     |_::_ -> var := true in
   let (project_file,makefile,is_install,opt),l =
-    try Project_file.process_cmd_line Filename.current_dir_name (None,None,Project_file.UnspecInstall,true) [] args
+    try
+      Project_file.process_cmd_line Filename.current_dir_name
+       (None,None,Project_file.UnspecInstall,true) [] args
     with Project_file.Parsing_error -> usage () in
   let (v_f,(mli_f,ml4_f,ml_f,mllib_f,mlpack_f),sps,sds as targets), inc, defs =
     Project_file.split_arguments l in
@@ -822,7 +926,9 @@ let do_makefile args =
     List.iter check_dep (Str.split (Str.regexp "[ \t]+") dependencies)) sps;
 
   let inc = ensure_root_dir targets inc in
-  if is_install <> Project_file.NoInstall then warn_install_at_root_directory targets inc;
+  if is_install <> Project_file.NoInstall then begin
+    warn_install_at_root_directory targets inc;
+  end;
   check_overlapping_include inc;
   banner ();
   header_includes ();
@@ -835,6 +941,7 @@ let do_makefile args =
   section "Special targets.";
   standard opt;
   install targets inc is_install;
+  merlin targets inc;
   clean sds sps;
   make_makefile sds;
   implicit ();
diff --git a/tools/coqc.ml b/tools/coqc.ml
index b7910e13..b12d4871 100644
--- a/tools/coqc.ml
+++ b/tools/coqc.ml
@@ -70,17 +70,6 @@ let parse_args () =
     | "-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;
-        parse (cfiles,args) rem
-    | ("-db"|"-debugger") :: rem ->
-        print_string "Warning: option -db/-debugger deprecated and ignored\n";
-        flush stdout;
-        parse (cfiles,args) rem
-
 (* Informative options *)
 
     | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage ()
@@ -99,13 +88,12 @@ let parse_args () =
 
 (* Options for coqtop : a) options with 0 argument *)
 
-    | ("-notactics"|"-bt"|"-debug"|"-nolib"|"-boot"|"-time"
+    | ("-notactics"|"-bt"|"-debug"|"-nolib"|"-boot"|"-time"|"-profile-ltac"
       |"-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"|"-native-compiler"
-      |"-verbose-compat-notations"|"-no-compat-notations"
       |"-indices-matter"|"-quick"|"-type-in-type"
       |"-async-proofs-always-delegate"|"-async-proofs-never-reopen-branch"
       as o) :: rem ->
@@ -118,27 +106,18 @@ let parse_args () =
       |"-load-ml-source"|"-require"|"-load-ml-object"
       |"-init-file"|"-dump-glob"|"-compat"|"-coqlib"|"-top"
       |"-async-proofs-j" |"-async-proofs-private-flags" |"-async-proofs" |"-w"
+      |"-o"|"-profile-ltac-cutoff" 
       as o) :: rem ->
 	begin
 	  match rem with
 	    | s :: rem' -> parse (cfiles,s::o::args) rem'
 	    | []        -> usage ()
 	end
+    | ("-I"|"-include" as o) :: s :: rem -> parse (cfiles,s::o::args) rem
 
 (* Options for coqtop : c) options with 1 argument and possibly more *)
 
-    | ("-I"|"-include" as o) :: rem ->
-	begin
-	  match rem with
-	  | s :: "-as" :: t :: rem' -> parse (cfiles,t::"-as"::s::o::args) rem'
-	  | s :: "-as" :: [] -> usage ()
-	  | s :: rem' -> parse (cfiles,s::o::args) rem'
-	  | []        -> usage ()
-	end
-    | "-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
+    | ("-R"|"-Q" as o) :: s :: t :: rem -> parse (cfiles,t::s::o::args) rem
     | ("-schedule-vio-checking"
       |"-check-vio-tasks" | "-schedule-vio2vo" as o) :: s :: rem ->
         let nodash, rem =
diff --git a/tools/coqdep.ml b/tools/coqdep.ml
index 79662a5d..a7c32e1d 100644
--- a/tools/coqdep.ml
+++ b/tools/coqdep.ml
@@ -9,6 +9,7 @@
 open Printf
 open Coqdep_lexer
 open Coqdep_common
+open System
 
 (** The basic parts of coqdep (i.e. the parts used by [coqdep -boot])
     are now in [Coqdep_common]. The code that remains here concerns
@@ -459,21 +460,14 @@ let rec parse = function
   | "-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_rec_dir_no_import add_known r [];
-     add_rec_dir_no_import add_known r (split_period ln);
-     parse ll
-  | "-I" :: r :: "-as" :: [] -> usage ()
   | "-I" :: r :: ll -> add_caml_dir r; parse ll
   | "-I" :: [] -> usage ()
-  | "-R" :: r :: "-as" :: ln :: ll -> add_rec_dir_import add_known r (split_period ln); parse ll
-  | "-R" :: r :: "-as" :: [] -> usage ()
   | "-R" :: r :: ln :: ll -> add_rec_dir_import add_known r (split_period ln); parse ll
   | "-Q" :: r :: ln :: ll -> add_rec_dir_no_import 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 := StrSet.add r !norec_dirnames; parse ll
+  | "-exclude-dir" :: r :: ll -> System.exclude_directory r; parse ll
   | "-exclude-dir" :: [] -> usage ()
   | "-coqlib" :: r :: ll -> Flags.coqlib_spec := true; Flags.coqlib := r; parse ll
   | "-coqlib" :: [] -> usage ()
@@ -497,17 +491,18 @@ let coqdep () =
   if !option_boot then begin
     add_rec_dir_import add_known "theories" ["Coq"];
     add_rec_dir_import add_known "plugins" ["Coq"];
+    add_caml_dir "tactics";
     add_rec_dir_import (fun _ -> add_caml_known) "theories" ["Coq"];
     add_rec_dir_import (fun _ -> add_caml_known) "plugins" ["Coq"];
   end else begin
-    Envars.set_coqlib ~fail:Errors.error;
+    Envars.set_coqlib ~fail:CErrors.error;
     let coqlib = Envars.coqlib () in
     add_rec_dir_import add_coqlib_known (coqlib//"theories") ["Coq"];
     add_rec_dir_import add_coqlib_known (coqlib//"plugins") ["Coq"];
     let user = coqlib//"user-contrib" in
     if Sys.file_exists user then add_rec_dir_no_import add_coqlib_known user [];
     List.iter (fun s -> add_rec_dir_no_import add_coqlib_known s [])
-      (Envars.xdg_dirs (fun x -> Pp.msg_warning (Pp.str x)));
+      (Envars.xdg_dirs (fun x -> Feedback.msg_warning (Pp.str x)));
     List.iter (fun s -> add_rec_dir_no_import add_coqlib_known s []) Envars.coqpath;
   end;
   List.iter (fun (f,d) -> add_mli_known f d ".mli") !mliAccu;
@@ -530,6 +525,6 @@ let coqdep () =
 let _ =
   try
     coqdep ()
-  with Errors.UserError(s,p) ->
+  with CErrors.UserError(s,p) ->
     let pp = if s <> "_" then Pp.(str s ++ str ": " ++ p) else p in
-    Pp.msgerrnl pp
+    Feedback.msg_error pp
diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml
index 58c8e884..0064aebd 100644
--- a/tools/coqdep_common.ml
+++ b/tools/coqdep_common.ml
@@ -9,10 +9,11 @@
 open Printf
 open Coqdep_lexer
 open Unix
+open Minisys
 
 (** [coqdep_boot] is a stripped-down version of [coqdep], whose
     behavior is the one of [coqdep -boot]. Its only dependencies
-    are [Coqdep_lexer] and [Unix], and it should stay so.
+    are [Coqdep_lexer], [Unix] and [Minisys], and it should stay so.
     If it need someday some additional information, pass it via
     options (see for instance [option_natdynlk] below).
 *)
@@ -32,26 +33,11 @@ let option_boot = ref false
 let option_mldep = ref None
 
 let norec_dirs = ref StrSet.empty
-let norec_dirnames = ref (List.fold_right StrSet.add ["CVS"; "_darcs"] StrSet.empty)
 
 let suffixe = ref ".vo"
 
 type dir = string option
 
-(* 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
     the extension. When no extension match, [(f,"")] is returned *)
@@ -179,11 +165,6 @@ let warning_module_notfound f s =
   eprintf "*** Warning: in file %s, library %s is required and has not been found in the loadpath!\n%!"
     f (String.concat "." s)
 
-let warning_notfound f s =
-  eprintf "*** Warning: in file %s, the file " f;
-  eprintf "%s.v is required and has not been found!\n" s;
-  flush stderr
-
 let warning_declare f s =
   eprintf "*** Warning: in file %s, declared ML module " f;
   eprintf "%s has not been found!\n" s;
@@ -203,6 +184,10 @@ let warning_clash file dir =
       eprintf "%s and %s; used the latter)\n" d2 d1
   | _ -> assert false
 
+let warning_cannot_open_dir dir =
+  eprintf "*** Warning: cannot open %s\n" dir;
+  flush stderr
+
 let safe_assoc from verbose file k =
   if verbose && StrListMap.mem k !clash_v then warning_clash file k;
   match search_v_known ?from k with
@@ -460,7 +445,7 @@ let mL_dependencies () =
        let efullname = escape fullname in
        printf "%s_MLLIB_DEPENDENCIES:=%s\n" efullname dep;
        printf "%s.cma:$(addsuffix .cmo,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname;
-       printf "%s.cmxa %s.cmxs:$(addsuffix .cmx,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname efullname;
+       printf "%s.cmxa:$(addsuffix .cmx,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname;
        flush stdout)
     (List.rev !mllibAccu);
   List.iter
@@ -470,7 +455,7 @@ let mL_dependencies () =
        let efullname = escape fullname in
        printf "%s_MLPACK_DEPENDENCIES:=%s\n" efullname dep;
        printf "%s.cmo:$(addsuffix .cmo,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname;
-       printf "%s.cmx %s.cmxs:$(addsuffix .cmx,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname efullname;
+       printf "%s.cmx:$(addsuffix .cmx,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname;
        flush stdout)
     (List.rev !mlpackAccu)
 
@@ -504,15 +489,15 @@ let add_caml_known phys_dir _ f =
     | _ -> ()
 
 let add_coqlib_known recur phys_dir log_dir f =
-  match get_extension f [".vo"] with
-    | (basename,".vo") ->
+  match get_extension f [".vo"; ".vio"] with
+    | (basename, (".vo" | ".vio")) ->
         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
     | _ -> ()
 
 let add_known recur phys_dir log_dir f =
-  match get_extension f [".v";".vo"] with
+  match get_extension f [".v"; ".vo"; ".vio"] with
     | (basename,".v") ->
 	let name = log_dir@[basename] in
 	let file = phys_dir//basename in
@@ -521,37 +506,30 @@ let add_known recur phys_dir log_dir f =
           let paths = List.tl (suffixes name) in
           let iter n = safe_hash_add compare_file clash_v vKnown (n, (file, false)) in
           List.iter iter paths
-    | (basename,".vo") when not(!option_boot) ->
+    | (basename, (".vo" | ".vio")) 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
     | _ -> ()
 
-(** Visit directory [phys_dir] (recursively unless [recur=false]) and
-    apply function add_file to each regular file encountered.
-    [log_dir] is the logical name of the [phys_dir].
-    [add_file] takes both directory names and the file. *)
+(* Visits all the directories under [dir], including [dir] *)
+
+let is_not_seen_directory phys_f =
+  not (StrSet.mem phys_f !norec_dirs)
+
 let rec add_directory recur add_file phys_dir log_dir =
-  let dirh = opendir phys_dir in
   register_dir_logpath phys_dir log_dir;
-  try
-    while true do
-      let f = readdir dirh in
-      (* we avoid all files and subdirs starting by '.' (e.g. .svn),
-         plus CVS and _darcs and any subdirs given via -exclude-dirs *)
-      if f.[0] <> '.' then
-        let phys_f = if phys_dir = "." then f else phys_dir//f in
-	match try (stat phys_f).st_kind with _ -> S_BLK with
-	  | S_DIR when recur ->
-              if StrSet.mem f !norec_dirnames then ()
-              else
-	        if StrSet.mem phys_f !norec_dirs then ()
-	        else (* TODO: warn if already seen this physycal dir? *)
-		  add_directory recur add_file phys_f (log_dir@[f])
-	  | S_REG -> add_file phys_dir log_dir f
-	  | _ -> ()
-    done
-  with End_of_file -> closedir dirh
+  let f = function
+    | FileDir (phys_f,f) ->
+        if is_not_seen_directory phys_f && recur then
+          add_directory true add_file phys_f (log_dir @ [f])
+    | FileRegular f ->
+        add_file phys_dir log_dir f
+  in
+  if exists_dir phys_dir then
+    process_directory f phys_dir
+  else
+    warning_cannot_open_dir phys_dir
 
 (** Simply add this directory and imports it, no subdirs. This is used
     by the implicit adding of the current path (which is not recursive). *)
@@ -564,12 +542,18 @@ let add_rec_dir_no_import add_file phys_dir log_dir =
 
 (** -R semantic: go in subdirs and suffixes of logical paths are known. *)
 let add_rec_dir_import add_file phys_dir log_dir =
-  handle_unix_error (add_directory true (add_file true) phys_dir) log_dir
+  add_directory true (add_file true) phys_dir log_dir
+
+(** -R semantic but only on immediate capitalized subdirs *)
+
+let add_rec_uppercase_subdirs add_file phys_dir log_dir =
+  process_subdirectories (fun phys_dir f ->
+    add_directory true (add_file true) phys_dir (log_dir@[String.capitalize f]))
+    phys_dir
 
 (** -I semantic: do not go in subdirs. *)
 let add_caml_dir phys_dir =
-  handle_unix_error (add_directory false add_caml_known phys_dir) []
-
+  add_directory false add_caml_known phys_dir []
 
 let rec treat_file old_dirname old_name =
   let name = Filename.basename old_name
@@ -584,15 +568,12 @@ let rec treat_file old_dirname old_name =
   match try (stat complete_name).st_kind with _ -> S_BLK with
     | S_DIR ->
 	(if name.[0] <> '.' then
-	   let dir=opendir complete_name in
            let newdirname =
              match dirname with
                | None -> name
                | Some d -> d//name
 	   in
-	   try
-	     while true do treat_file (Some newdirname) (readdir dir) done
-	   with End_of_file -> closedir dir)
+           Array.iter (treat_file (Some newdirname)) (Sys.readdir complete_name))
     | S_REG ->
 	(match get_extension name [".v";".ml";".mli";".ml4";".mllib";".mlpack"] with
 	   | (base,".v") ->
diff --git a/tools/coqdep_common.mli b/tools/coqdep_common.mli
index 97bdfaef..633c474a 100644
--- a/tools/coqdep_common.mli
+++ b/tools/coqdep_common.mli
@@ -22,10 +22,8 @@ val option_boot : bool ref
 val option_natdynlk : bool ref
 val option_mldep : string option ref
 val norec_dirs : StrSet.t ref
-val norec_dirnames : StrSet.t ref
 val suffixe : string ref
 type dir = string option
-val ( // ) : string -> string -> string
 val get_extension : string -> string list -> string * string
 val basename_noext : string -> string
 val mlAccu : (string * string * dir) list ref
@@ -51,9 +49,6 @@ val suffixes : 'a list -> 'a list list
 val add_known : bool -> string -> string list -> string -> unit
 val add_coqlib_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
 
 (** Simply add this directory and imports it, no subdirs. This is used
@@ -69,5 +64,8 @@ val add_rec_dir_no_import :
 val add_rec_dir_import :
   (bool -> string -> string list -> string -> unit) -> string -> string list -> unit
 
+val add_rec_uppercase_subdirs :
+  (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.mll b/tools/coqdep_lexer.mll
index b16dd338..eb233b8f 100644
--- a/tools/coqdep_lexer.mll
+++ b/tools/coqdep_lexer.mll
@@ -25,13 +25,6 @@
   exception Fin_fichier
   exception Syntax_error of int*int
 
-  let module_current_name = ref []
-  let module_names = ref []
-  let ml_module_name = ref ""
-  let loadpath = ref ""
-
-  let mllist = ref ([] : string list)
-
   let field_name s = String.sub s 1 (String.length s - 1)
 
   let unquote_string s =
@@ -46,11 +39,6 @@
 
   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']
@@ -81,9 +69,9 @@ let dot = '.' ( space+ | eof)
 
 rule coq_action = parse
   | "Require" space+
-      { require_modifiers lexbuf }
+      { require_modifiers None lexbuf }
   | "Local"? "Declare" space+ "ML" space+ "Module" space+
-      { mllist := []; modules lexbuf }
+      { modules [] lexbuf }
   | "Load" space+
       { load_file lexbuf }
   | "Add" space+ "LoadPath" space+
@@ -109,38 +97,34 @@ and from_rule = parse
   | 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 }
+      { let from = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in
+        consume_require (Some from) lexbuf }
   | eof
       { syntax_error lexbuf }
   | _
       { syntax_error lexbuf }
 
-and require_modifiers = parse
+and require_modifiers from = parse
   | "(*"
-      { comment lexbuf; require_modifiers lexbuf }
+      { comment lexbuf; require_modifiers from lexbuf }
   | "Import" space+
-      { require_file lexbuf }
+      { require_file from lexbuf }
   | "Export" space+
-      { require_file lexbuf }
+      { require_file from lexbuf }
   | space+
-      { require_modifiers lexbuf }
+      { require_modifiers from lexbuf }
   | eof
       { syntax_error lexbuf }
   | _
-      { backtrack lexbuf ; require_file lexbuf }
+      { backtrack lexbuf ; require_file from lexbuf }
 
-and consume_require = parse
+and consume_require from = parse
   | "(*"
-      { comment lexbuf; consume_require lexbuf }
+      { comment lexbuf; consume_require from lexbuf }
   | space+
-      { consume_require lexbuf }
+      { consume_require from lexbuf }
   | "Require" space+
-      { require_modifiers lexbuf }
-  | eof
-      { syntax_error lexbuf }
+      { require_modifiers from lexbuf }
   | _
       { syntax_error lexbuf }
 
@@ -152,20 +136,19 @@ and add_loadpath = parse
   | eof
       { syntax_error lexbuf }
   | '"' [^ '"']* '"' (*'"'*)
-      { loadpath := unquote_string (lexeme lexbuf);
-        add_loadpath_as lexbuf }
+      { add_loadpath_as (unquote_string (lexeme lexbuf)) lexbuf }
 
-and add_loadpath_as = parse
+and add_loadpath_as path = parse
   | "(*"
-      { comment lexbuf; add_loadpath_as lexbuf }
+      { comment lexbuf; add_loadpath_as path lexbuf }
   | space+
-      { add_loadpath_as lexbuf }
+      { add_loadpath_as path lexbuf }
   | "as"
       { let qid = coq_qual_id lexbuf in
         skip_to_dot lexbuf;
-        AddRecLoadPath (!loadpath,qid) }
+        AddRecLoadPath (path, qid) }
   | dot
-      { AddLoadPath !loadpath }
+      { AddLoadPath path }
 
 and caml_action = parse
   | space +
@@ -176,8 +159,7 @@ and caml_action = parse
         { caml_action lexbuf }
   | caml_low_ident { caml_action lexbuf }
   | caml_up_ident
-      { ml_module_name := Lexing.lexeme lexbuf;
-        qual_id lexbuf }
+      { qual_id (Lexing.lexeme lexbuf) lexbuf }
   | ['0'-'9']+
     | '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+
     | '0' ['o' 'O'] ['0'-'7']+
@@ -260,18 +242,15 @@ and load_file = parse
   | _
       { syntax_error lexbuf }
 
-and require_file = parse
+and require_file from = parse
   | "(*"
-      { comment lexbuf; require_file lexbuf }
+      { comment lexbuf; require_file from lexbuf }
   | space+
-      { require_file lexbuf }
+      { require_file from lexbuf }
   | coq_ident
-      { module_current_name := [Lexing.lexeme lexbuf];
-        module_names := [coq_qual_id_tail lexbuf];
-        let qid = coq_qual_id_list lexbuf in
+      { let name = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in
+        let qid = coq_qual_id_list [name] lexbuf in
         parse_dot lexbuf;
-        let from = !from_pre_ident in
-        from_pre_ident := None;
         Require (from, qid) }
   | eof
       { syntax_error lexbuf }
@@ -294,66 +273,55 @@ and coq_qual_id = parse
   | space+
       { coq_qual_id lexbuf }
   | coq_ident
-      { module_current_name := [Lexing.lexeme lexbuf];
-        coq_qual_id_tail lexbuf }
-  | eof
-      { syntax_error lexbuf }
+      { coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf }
   | _
-      { backtrack lexbuf;
-        let qid = List.rev !module_current_name in
-        module_current_name := [];
-        qid }
+      { syntax_error lexbuf }
 
-and coq_qual_id_tail = parse
+and coq_qual_id_tail module_name = parse
   | "(*"
-      { comment lexbuf; coq_qual_id_tail lexbuf }
+      { comment lexbuf; coq_qual_id_tail module_name lexbuf }
   | space+
-      { coq_qual_id_tail lexbuf }
+      { coq_qual_id_tail module_name lexbuf }
   | coq_field
-      { module_current_name :=
-          field_name (Lexing.lexeme lexbuf) :: !module_current_name;
-        coq_qual_id_tail lexbuf }
+      { coq_qual_id_tail (field_name (Lexing.lexeme lexbuf) :: module_name) lexbuf }
   | eof
       { syntax_error lexbuf }
   | _
       { backtrack lexbuf;
-        let qid = List.rev !module_current_name in
-        module_current_name := [];
-        qid }
+        List.rev module_name }
 
-and coq_qual_id_list = parse
+and coq_qual_id_list module_names = parse
   | "(*"
-      { comment lexbuf; coq_qual_id_list lexbuf }
+      { comment lexbuf; coq_qual_id_list module_names lexbuf }
   | space+
-      { coq_qual_id_list lexbuf }
+      { coq_qual_id_list module_names lexbuf }
   | coq_ident
-      { module_current_name := [Lexing.lexeme lexbuf];
-        module_names := coq_qual_id_tail lexbuf :: !module_names;
-        coq_qual_id_list lexbuf
+      { let name = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in
+        coq_qual_id_list (name :: module_names) lexbuf
       }
   | eof
       { syntax_error lexbuf }
   | _
       { backtrack lexbuf;
-        List.rev !module_names }
+        List.rev module_names }
 
-and modules = parse
+and modules mllist = parse
   | space+
-      { modules lexbuf }
+      { modules mllist lexbuf }
   | "(*"
-      { comment lexbuf; modules lexbuf }
+      { comment lexbuf; modules mllist lexbuf }
   | '"' [^'"']* '"'
       { let lex = (Lexing.lexeme lexbuf) in
 	let str = String.sub lex 1 (String.length lex - 2) in
-	mllist := str :: !mllist; modules lexbuf}
+        modules (str :: mllist) lexbuf}
   | eof
       { syntax_error lexbuf }
   | _
-      { (Declare (List.rev !mllist)) }
+      { Declare (List.rev mllist) }
 
-and qual_id = parse
-  | '.' [^ '.' '(' '['] {
-      Use_module (String.uncapitalize !ml_module_name) }
+and qual_id ml_module_name = parse
+  | '.' [^ '.' '(' '[']
+      { Use_module (String.uncapitalize ml_module_name) }
   | eof { raise Fin_fichier }
   | _ { caml_action lexbuf }
 
diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll
index 431080c6..919f37b9 100644
--- a/tools/coqdoc/cpretty.mll
+++ b/tools/coqdoc/cpretty.mll
@@ -75,7 +75,7 @@
     let stop_env () = if !r then stop (); r := false in
       (fun x -> !r), start_env, stop_env
       
-  let in_emph, start_emph, stop_emph = in_env Output.start_emph Output.stop_emph
+  let _, start_emph, stop_emph = in_env Output.start_emph Output.stop_emph
   let in_quote, start_quote, stop_quote = in_env Output.start_quote Output.stop_quote
 
   let url_buffer = Buffer.create 40
@@ -111,12 +111,6 @@
     Cdglobals.gallina := s.st_gallina;
     Cdglobals.light := s.st_light
 
-  let without_ref r f x = save_state (); r := false; f x; restore_state ()
-
-  let without_gallina = without_ref Cdglobals.gallina
-
-  let without_light = without_ref Cdglobals.light
-
   let begin_show () = save_state (); Cdglobals.gallina := false; Cdglobals.light := false
   let end_show () = restore_state ()
 
@@ -245,6 +239,12 @@
     let s = String.sub s isp (String.length s - isp) in
     Output.keyword s (lexeme_start lexbuf + isp)
 
+  let only_gallina () =
+    !Cdglobals.gallina && !in_proof <> None
+
+  let parse_comments () =
+    !Cdglobals.parse_comments && not (only_gallina ())
+
 }
 
 (*s Regular expressions *)
@@ -486,7 +486,7 @@ rule coq_bol = parse
 	in if eol then coq_bol lexbuf else coq lexbuf }
   | space* end_kw {
       let eol =
-	if not (!in_proof <> None && !Cdglobals.gallina) then
+	if not (only_gallina ()) then
 	  begin backtrack lexbuf; body_bol lexbuf end
 	else skip_to_dot lexbuf
       in
@@ -535,14 +535,15 @@ rule coq_bol = parse
 	coq_bol lexbuf }
   | space* "(*"
       { comment_level := 1;
-	if !Cdglobals.parse_comments then begin
-	  let s = lexeme lexbuf in
-	  let nbsp,isp = count_spaces s in
-	    Output.indentation nbsp;
-	    Output.start_comment ();
-	end;
-	let eol = comment lexbuf in
-	  if eol then coq_bol lexbuf else coq lexbuf }
+        let eol =
+          if parse_comments () then begin
+            let s = lexeme lexbuf in
+            let nbsp, isp = count_spaces s in
+            Output.indentation nbsp;
+            Output.start_comment ();
+            comment lexbuf
+          end else skipped_comment lexbuf in
+        if eol then coq_bol lexbuf else coq lexbuf }
   | eof
       { () }
   | _
@@ -550,7 +551,7 @@ rule coq_bol = parse
 	  if not !Cdglobals.gallina then
 	    begin backtrack lexbuf; body_bol lexbuf end
 	  else
-	    skip_to_dot lexbuf
+	    skip_to_dot_or_brace lexbuf
 	in
 	  if eol then coq_bol lexbuf else coq lexbuf }
 
@@ -558,7 +559,7 @@ rule coq_bol = parse
 
 and coq = parse
   | nl
-      { if not (!in_proof <> None && !Cdglobals.gallina) then Output.line_break(); coq_bol lexbuf }
+      { if not (only_gallina ()) then Output.line_break(); coq_bol lexbuf }
   | "(**" space_nl
       { Output.end_coq (); Output.start_doc ();
 	let eol = doc_bol lexbuf in
@@ -566,16 +567,12 @@ and coq = parse
 	  if eol then coq_bol lexbuf else coq lexbuf }
   | "(*"
       { comment_level := 1;
-	if !Cdglobals.parse_comments then begin
-	  let s = lexeme lexbuf in
-	  let nbsp,isp = count_spaces s in
-	    Output.indentation nbsp;
-	    Output.start_comment ();
-	end;
-	let eol = comment lexbuf in
-	  if eol then coq_bol lexbuf
-          else coq lexbuf
-      }
+        let eol =
+          if parse_comments () then begin
+            Output.start_comment ();
+            comment lexbuf
+          end else skipped_comment lexbuf in
+        if eol then coq_bol lexbuf else coq lexbuf }
   | nl+ space* "]]"
       { if not !formatted then
 	begin
@@ -650,7 +647,7 @@ and coq = parse
 	  if not !Cdglobals.gallina then
 	    begin backtrack lexbuf; body lexbuf end
 	  else
-	    skip_to_dot lexbuf
+	    skip_to_dot_or_brace lexbuf
 	in
 	  if eol then coq_bol lexbuf else coq lexbuf}
 
@@ -678,7 +675,7 @@ and doc_bol = parse
         in
           match check_start_list line with
           | Neither -> backtrack_past_newline lexbuf; doc None lexbuf
-          | List n -> Output.paragraph ();
+          | List n -> if lines > 0 then Output.paragraph ();
                       Output.item 1; doc (Some [n]) lexbuf
           | Rule -> Output.rule (); doc None lexbuf
       }
@@ -739,24 +736,7 @@ and doc_list_bol indents = parse
         in
         let (n_spaces,_) = count_spaces buf in
         match find_level indents n_spaces with
-        | InLevel _ ->
-            Output.paragraph ();
-            backtrack_past_newline lexbuf;
-            doc_list_bol indents lexbuf
-        | StartLevel n ->
-            if n = 1 then
-              begin
-                Output.stop_item ();
-                backtrack_past_newline lexbuf;
-                doc_bol lexbuf
-              end
-            else
-              begin
-                Output.paragraph ();
-                backtrack_past_newline lexbuf;
-                doc_list_bol indents lexbuf
-              end
-        | Before -> 
+        | StartLevel 1 | Before ->
         (* Here we were at the beginning of a line, and it was blank.
            The next line started before any list items.  So: insert
            a paragraph for the empty line, rewind to whatever's just
@@ -766,6 +746,10 @@ and doc_list_bol indents = parse
             Output.paragraph ();
             backtrack_past_newline lexbuf;
             doc_bol lexbuf
+        | StartLevel _ | InLevel _ ->
+            Output.paragraph ();
+            backtrack_past_newline lexbuf;
+            doc_list_bol indents lexbuf
 
       }
   | space* _
@@ -774,10 +758,7 @@ and doc_list_bol indents = parse
         | Before -> Output.stop_item (); backtrack lexbuf;
                     doc_bol lexbuf
         | StartLevel n ->
-            (if n = 1 then
-               Output.stop_item ()
-             else
-               Output.reach_item_level (n-1));
+            Output.reach_item_level (n-1);
             backtrack lexbuf;
             doc (Some (take (n-1) indents)) lexbuf
         | InLevel (n,_) ->
@@ -820,9 +801,10 @@ and doc indents = parse
                         | Some is -> doc_list_bol is
                         | None   -> doc_bol
         in
-        let eol = comment lexbuf in
-          if eol then bol_parse lexbuf else doc indents lexbuf
-      }
+        let eol =
+          if !Cdglobals.parse_comments then comment lexbuf
+          else skipped_comment lexbuf in
+        if eol then bol_parse lexbuf else doc indents lexbuf }
   | '*'* "*)" space_nl* "(**"
       {(match indents with
         | Some _ -> Output.stop_item ()
@@ -941,7 +923,9 @@ and escaped_coq = parse
         Output.sublexer_in_doc '['; escaped_coq lexbuf }
   | "(*"
       { Tokens.flush_sublexer (); comment_level := 1;
-        ignore (comment lexbuf); escaped_coq lexbuf }
+        ignore (if !Cdglobals.parse_comments then comment lexbuf
+                else skipped_comment lexbuf);
+        escaped_coq lexbuf }
   | "*)"
       { (* likely to be a syntax error: we escape *) backtrack lexbuf }
   | eof
@@ -981,76 +965,101 @@ and comments = parse
   | _
       { Output.char (lexeme_char lexbuf 0); comments lexbuf }
 
-(*s Skip comments *)
+and skipped_comment = parse
+  | "(*"
+      { incr comment_level;
+	skipped_comment lexbuf }
+  | "*)" space* nl
+      { decr comment_level;
+        if !comment_level > 0 then skipped_comment lexbuf else true }
+  | "*)"
+      { decr comment_level;
+        if !comment_level > 0 then skipped_comment lexbuf else false }
+  | eof { false }
+  | _ { skipped_comment lexbuf }
 
 and comment = parse
-  | "(*" { incr comment_level;
-	   if !Cdglobals.parse_comments then Output.start_comment ();
-	   comment lexbuf }
-  | "*)" space* nl {
-      if !Cdglobals.parse_comments then
-	(Output.end_comment (); Output.line_break ());
-      decr comment_level; if !comment_level > 0 then comment lexbuf else true }
-  | "*)" {
-      if !Cdglobals.parse_comments then (Output.end_comment ());
-      decr comment_level; if !comment_level > 0 then comment lexbuf else false }
-  | "[" {
-      if !Cdglobals.parse_comments then
-	if !Cdglobals.plain_comments then Output.char '['
+  | "(*"
+      { incr comment_level;
+        Output.start_comment ();
+        comment lexbuf }
+  | "*)" space* nl
+      { Output.end_comment ();
+        Output.line_break ();
+        decr comment_level;
+        if !comment_level > 0 then comment lexbuf else true }
+  | "*)"
+      { Output.end_comment ();
+        decr comment_level;
+        if !comment_level > 0 then comment lexbuf else false }
+  | "["
+      { if !Cdglobals.plain_comments then Output.char '['
         else (brackets := 1; Output.start_inline_coq ();
               escaped_coq lexbuf; Output.end_inline_coq ());
-      comment lexbuf }
-  | "[[" nl {
-      if !Cdglobals.parse_comments then
-        if !Cdglobals.plain_comments then (Output.char '['; Output.char '[')
+        comment lexbuf }
+  | "[[" nl
+      { if !Cdglobals.plain_comments then (Output.char '['; Output.char '[')
         else (formatted := true;
               Output.start_inline_coq_block ();
               let _ = body_bol lexbuf in
                 Output.end_inline_coq_block (); formatted := false);
-      comment lexbuf}
+        comment lexbuf }
   | "$"
-      { if !Cdglobals.parse_comments then
-          if !Cdglobals.plain_comments then Output.char '$'
-          else (Output.start_latex_math (); escaped_math_latex lexbuf);
+      { if !Cdglobals.plain_comments then Output.char '$'
+        else (Output.start_latex_math (); escaped_math_latex lexbuf);
         comment lexbuf }
   | "$$"
-      { if !Cdglobals.parse_comments
-        then
-          (if !Cdglobals.plain_comments then Output.char '$'; Output.char '$');
-        doc None lexbuf }
+      { if !Cdglobals.plain_comments then Output.char '$';
+        Output.char '$';
+        comment lexbuf }
   | "%"
-      { if !Cdglobals.parse_comments
-          then
-            if !Cdglobals.plain_comments then Output.char '%'
-            else escaped_latex lexbuf; comment lexbuf }
+      { if !Cdglobals.plain_comments then Output.char '%'
+        else escaped_latex lexbuf;
+        comment lexbuf }
   | "%%"
-      { if !Cdglobals.parse_comments
-        then
-          (if !Cdglobals.plain_comments then Output.char '%'; Output.char '%');
+      { if !Cdglobals.plain_comments then Output.char '%';
+        Output.char '%';
         comment lexbuf }
   | "#"
-      { if !Cdglobals.parse_comments
-        then
-          if !Cdglobals.plain_comments then Output.char '$'
-          else escaped_html lexbuf; comment lexbuf }
+      { if !Cdglobals.plain_comments then Output.char '#'
+        else escaped_html lexbuf;
+        comment lexbuf }
   | "##"
-      { if !Cdglobals.parse_comments
-        then
-          (if !Cdglobals.plain_comments then Output.char '#'; Output.char '#');
+      { if !Cdglobals.plain_comments then Output.char '#';
+        Output.char '#';
         comment lexbuf }
   | eof  { false }
-  | space+ { if !Cdglobals.parse_comments
-             then Output.indentation (fst (count_spaces (lexeme lexbuf)));
-             comment lexbuf }
-  | nl   { if !Cdglobals.parse_comments
-           then Output.line_break (); comment lexbuf }
-  | _    { if !Cdglobals.parse_comments then Output.char (lexeme_char lexbuf 0);
-           comment lexbuf }
+  | space+
+      { Output.indentation (fst (count_spaces (lexeme lexbuf)));
+        comment lexbuf }
+  | nl
+      { Output.line_break ();
+        comment lexbuf }
+  | _ { Output.char (lexeme_char lexbuf 0);
+        comment lexbuf }
 
 and skip_to_dot = parse
   | '.' space* nl { true }
   | eof | '.' space+ { false }
-  | "(*" { comment_level := 1; ignore (comment lexbuf); skip_to_dot lexbuf }
+  | "(*"
+      { comment_level := 1;
+        ignore (skipped_comment lexbuf);
+        skip_to_dot lexbuf }
+  | _ { skip_to_dot lexbuf }
+
+and skip_to_dot_or_brace = parse
+  | '.' space* nl { true }
+  | eof | '.' space+ { false }
+  | "(*"
+      { comment_level := 1;
+        ignore (skipped_comment lexbuf);
+        skip_to_dot_or_brace lexbuf }
+  | "}" space* nl
+      { true }
+  | "}"
+      { false }
+  | space*
+      { skip_to_dot_or_brace lexbuf }
   | _ { skip_to_dot lexbuf }
 
 and body_bol = parse
@@ -1120,12 +1129,18 @@ and body = parse
 	let eol = doc_bol lexbuf in
 	  Output.end_doc (); Output.start_coq ();
 	  if eol then body_bol lexbuf else body lexbuf }
-  | "(*" { Tokens.flush_sublexer(); comment_level := 1;
-	   if !Cdglobals.parse_comments then Output.start_comment ();
-	   let eol = comment lexbuf in
-	     if eol
-	     then begin if not !Cdglobals.parse_comments then Output.line_break(); body_bol lexbuf end
-	     else body lexbuf }
+  | "(*"
+      { Tokens.flush_sublexer(); comment_level := 1;
+        let eol =
+          if parse_comments () then begin
+            Output.start_comment ();
+            comment lexbuf
+          end else begin
+            let eol = skipped_comment lexbuf in
+            if eol then Output.line_break();
+            eol
+          end in
+	if eol then body_bol lexbuf else body lexbuf }
   | "where" 
       { Tokens.flush_sublexer();
         Output.ident (lexeme lexbuf) None;
diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml
index 47acc7b4..9be791a8 100644
--- a/tools/coqdoc/index.ml
+++ b/tools/coqdoc/index.ml
@@ -77,32 +77,6 @@ let find m l = Hashtbl.find reftable (m, l)
 
 let find_string m s = let (m,s,t) = Hashtbl.find byidtable s in Ref (m,s,t)
 
-(*s Manipulating path prefixes *)
-
-type stack = string list
-
-let rec string_of_stack st =
-  match st with
-    | [] -> ""
-    | x::[] -> x
-    | x::tl -> (string_of_stack tl) ^ "." ^ x
-
-let empty_stack = []
-
-let module_stack = ref empty_stack
-let section_stack = ref empty_stack
-
-let push st p = st := p::!st
-let pop st =
-  match !st with
-    | [] -> ()
-    | _::tl -> st := tl
-
-let head st =
-  match st with
-    | [] -> ""
-    | x::_ -> x
-
 (* Coq modules *)
 
 let split_sp s =
diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml
index 2b269096..82d3d62b 100644
--- a/tools/coqdoc/output.ml
+++ b/tools/coqdoc/output.ml
@@ -953,7 +953,7 @@ module TeXmacs = struct
 
   (*s Latex preamble *)
 
-  let (preamble : string Queue.t) =
+  let (_ : string Queue.t) =
     in_doc := false; Queue.create ()
 
   let header () =
@@ -1122,7 +1122,6 @@ module Raw = struct
     for i = 0 to String.length s - 1 do char s.[i] done
 
   let start_module () = ()
-  let end_module () = ()
 
   let start_latex_math () = ()
   let stop_latex_math () = ()
diff --git a/tools/coqmktop.ml b/tools/coqmktop.ml
index a45c625b..eaf938e8 100644
--- a/tools/coqmktop.ml
+++ b/tools/coqmktop.ml
@@ -149,7 +149,7 @@ 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  -ocamlfind dir Specify where the ocamlfind binary is\
 \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\
@@ -167,8 +167,8 @@ let parse_args () =
     (* 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
+    | "-ocamlfind" :: d :: rem ->
+	Flags.ocamlfind_spec := true; Flags.ocamlfind := 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
@@ -235,7 +235,7 @@ let declare_loading_string () =
 \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                   then CErrors.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) };;\
@@ -265,11 +265,10 @@ let create_tmp_main_file modules =
 let main () =
   let (options, userfiles) = parse_args () in
   (* Directories: *)
-  let () = Envars.set_coqlib ~fail:Errors.error in
-  let camlbin = Envars.camlbin () in
+  let () = Envars.set_coqlib ~fail:CErrors.error 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
+  let prog = if !opt then "opt" 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
@@ -284,14 +283,14 @@ let main () =
       (std_includes basedir) @ tolink @ [ main_file ] @ topstart
     in
     if !echo then begin
-      let command = String.concat " " (prog::args) in
+      let command = String.concat " " (Envars.ocamlfind ()::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
+    let exitcode = run_command (Envars.ocamlfind ()) (prog::args) in
     clean main_file;
     exitcode
   with reraise -> clean main_file; raise reraise
diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml
index 1fdda04c..8fcca535 100644
--- a/tools/fake_ide.ml
+++ b/tools/fake_ide.ml
@@ -17,7 +17,19 @@ type coqtop = {
   xml_parser : Xml_parser.t;
 }
 
-let logger level content = prerr_endline content
+let print_xml chan xml =
+  let rec print = function
+  | Xml_datatype.PCData s -> output_string chan s
+  | Xml_datatype.Element (_, _, children) -> List.iter print children
+  in
+  print xml
+
+let error_xml s =
+  Printf.eprintf "fake_id: error: %a\n%!" print_xml s;
+  exit 1
+
+let logger level content =
+  Printf.eprintf "%a\n%! " print_xml (Richpp.repr content)
 
 let base_eval_call ?(print=true) ?(fail=true) call coqtop =
   if print then prerr_endline (Xmlprotocol.pr_call call);
@@ -25,21 +37,20 @@ let base_eval_call ?(print=true) ?(fail=true) call coqtop =
   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
+    match Xmlprotocol.is_message xml with
+    | Some (level, _loc, content) ->
       logger level content;
       loop ()
-    else if Feedback.is_feedback xml then
-      loop ()
-    else (Xmlprotocol.to_answer call xml)
+    | None ->
+      if Xmlprotocol.is_feedback xml then
+        loop ()
+      else Xmlprotocol.to_answer call xml
   in
   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
+  | Interface.Fail (_,_,s) when fail -> error_xml (Richpp.repr s)
+  | Interface.Fail (_,_,s) as x -> Printf.eprintf "%a\n%!" print_xml (Richpp.repr s); x
   | x -> x
 
 let eval_call c q = ignore(base_eval_call c q)
@@ -188,7 +199,7 @@ let print_document () =
 module GUILogic = struct
 
   let after_add = function
-    | Interface.Fail (_,_,s) -> error s
+    | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s)
     | Interface.Good (id, (Util.Inl (), _)) ->
         Document.assign_tip_id doc id
     | Interface.Good (id, (Util.Inr tip, _)) ->
@@ -200,7 +211,7 @@ module GUILogic = struct
   let at id id' _ = Stateid.equal id' id
   
   let after_edit_at (id,need_unfocus) = function
-    | Interface.Fail (_,_,s) -> error s
+    | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s)
     | Interface.Good (Util.Inl ()) ->
         if need_unfocus then Document.unfocus doc;
         ignore(Document.cut_at doc id);
@@ -323,7 +334,7 @@ let main =
   let finish () =
     match base_eval_call (Xmlprotocol.status true) coq with
     | Interface.Good _ -> exit 0
-    | Interface.Fail (_,_,s) -> error s in
+    | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s) in
   (* The main loop *)
   init ();
   while true do
diff --git a/tools/ocamllibdep.mll b/tools/ocamllibdep.mll
new file mode 100644
index 00000000..bf82be09
--- /dev/null
+++ b/tools/ocamllibdep.mll
@@ -0,0 +1,217 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - 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 Syntax_error of int*int
+
+  let syntax_error lexbuf =
+    raise (Syntax_error (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf))
+}
+
+let space = [' ' '\t' '\n' '\r']
+let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255']
+let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']
+let identchar =
+  ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
+let caml_up_ident = uppercase identchar*
+let caml_low_ident = lowercase identchar*
+
+rule mllib_list = parse
+  | caml_up_ident { let s = String.uncapitalize (Lexing.lexeme lexbuf)
+		in s :: mllib_list lexbuf }
+  | "*predef*" { mllib_list lexbuf }
+  | space+ { mllib_list lexbuf }
+  | eof { [] }
+  | _ { syntax_error lexbuf }
+
+{
+open Printf
+open Unix
+
+(* Makefile's escaping rules are awful: $ is escaped by doubling and
+   other special characters are escaped by backslash prefixing while
+   backslashes themselves must be escaped only if part of a sequence
+   followed by a special character (i.e. in case of ambiguity with a
+   use of it as escaping character).  Moreover (even if not crucial)
+   it is apparently not possible to directly escape ';' and leading '\t'. *)
+
+let escape =
+  let s' = Buffer.create 10 in
+  fun s ->
+    Buffer.clear s';
+    for i = 0 to String.length s - 1 do
+      let c = s.[i] in
+      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
+	let j = ref (i-1) in
+	while !j >= 0 && s.[!j] = '\\' do 
+	  Buffer.add_char s' '\\'; decr j (* escape all preceding '\' *)
+	done;
+	Buffer.add_char s' '\\';
+      end;
+      if c = '$' then Buffer.add_char s' '$';
+      Buffer.add_char s' c
+    done;
+    Buffer.contents s'
+
+(* 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
+    the extension. When no extension match, [(f,"")] is returned *)
+
+let rec get_extension f = function
+  | [] -> (f, "")
+  | s :: _ when Filename.check_suffix f s -> (Filename.chop_suffix f s, s)
+  | _ :: l -> get_extension f l
+
+let file_name s = function
+  | None     -> s
+  | Some "." -> s
+  | Some d   -> d // s
+
+type dir = string option
+
+let add_directory add_file phys_dir =
+  Array.iter (fun f ->
+    (* we avoid all files starting by '.' *)
+    if f.[0] <> '.' then
+      let phys_f = if phys_dir = "." then f else phys_dir//f in
+      match try (stat phys_f).st_kind with _ -> S_BLK with
+      | S_REG -> add_file phys_dir f
+      | _ -> ()) (Sys.readdir phys_dir)
+
+let error_cannot_parse s (i,j) =
+  Printf.eprintf "File \"%s\", characters %i-%i: Syntax error\n" s i j;
+  exit 1
+
+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 * 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 search x =
+    try Some (fst (Hashtbl.find h x))
+    with Not_found -> None
+  in add, search
+
+let add_ml_known, search_ml_known = mkknown ()
+let add_mlpack_known, search_mlpack_known = mkknown ()
+
+let mllibAccu = ref ([] : (string * dir) list)
+let mlpackAccu = ref ([] : (string * dir) list)
+
+let add_caml_known phys_dir f =
+  let basename,suff = get_extension f [".ml";".ml4";".mlpack"] in
+  match suff with
+    | ".ml"|".ml4" -> add_ml_known basename (Some phys_dir) suff
+    | ".mlpack" -> add_mlpack_known basename (Some phys_dir) suff
+    | _ -> ()
+
+let add_caml_dir phys_dir =
+  handle_unix_error (add_directory add_caml_known) phys_dir
+
+let traite_fichier_modules md ext =
+  try
+    let chan = open_in (md ^ ext) in
+    let list = mllib_list (Lexing.from_channel chan) in
+    List.fold_left
+      (fun acc str ->
+       match search_mlpack_known str with
+       | Some mldir -> (file_name str mldir) :: acc
+       | None ->
+	  match search_ml_known str with
+	  | Some mldir -> (file_name str mldir) :: acc
+	  | None -> acc) [] (List.rev list)
+  with
+    | Sys_error _ -> []
+    | Syntax_error (i,j) -> error_cannot_parse (md^ext) (i,j)
+
+let addQueue q v = q := v :: !q
+
+let treat_file old_name =
+  let name = Filename.basename old_name in
+  let dirname = Some (Filename.dirname old_name) in
+  match get_extension name [".mllib";".mlpack"] with
+  | (base,".mllib") -> addQueue mllibAccu (base,dirname)
+  | (base,".mlpack") -> addQueue mlpackAccu (base,dirname)
+  | _ -> ()
+
+let mllib_dependencies () =
+  List.iter
+    (fun (name,dirname) ->
+       let fullname = file_name name dirname in
+       let deps = traite_fichier_modules fullname ".mllib" in
+       let sdeps = String.concat " " deps in
+       let efullname = escape fullname in
+       printf "%s_MLLIB_DEPENDENCIES:=%s\n" efullname sdeps;
+       printf "%s.cma:$(addsuffix .cmo,$(%s_MLLIB_DEPENDENCIES))\n"
+         efullname efullname;
+       printf "%s.cmxa:$(addsuffix .cmx,$(%s_MLLIB_DEPENDENCIES))\n"
+         efullname efullname;
+       flush Pervasives.stdout)
+    (List.rev !mllibAccu)
+
+let mlpack_dependencies () =
+  List.iter
+    (fun (name,dirname) ->
+       let fullname = file_name name dirname in
+       let modname = String.capitalize name in
+       let deps = traite_fichier_modules fullname ".mlpack" in
+       let sdeps = String.concat " " deps in
+       let efullname = escape fullname in
+       printf "%s_MLPACK_DEPENDENCIES:=%s\n" efullname sdeps;
+       List.iter (fun d -> printf "%s_FORPACK:= -for-pack %s\n" d modname) deps;
+       printf "%s.cmo:$(addsuffix .cmo,$(%s_MLPACK_DEPENDENCIES))\n"
+         efullname efullname;
+       printf "%s.cmx:$(addsuffix .cmx,$(%s_MLPACK_DEPENDENCIES))\n"
+         efullname efullname;
+       flush Pervasives.stdout)
+    (List.rev !mlpackAccu)
+
+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_caml_dir r;
+       parse ll
+  | f :: ll -> treat_file f; parse ll
+  | [] -> ()
+
+let main () =
+  if Array.length Sys.argv < 2 then exit 1;
+  parse (List.tl (Array.to_list Sys.argv));
+  mllib_dependencies ();
+  mlpack_dependencies ()
+
+let _ = Printexc.catch main ()
+}
diff --git a/toplevel/assumptions.ml b/toplevel/assumptions.ml
index 2a3e6536..45c539e2 100644
--- a/toplevel/assumptions.ml
+++ b/toplevel/assumptions.ml
@@ -15,7 +15,7 @@
    Module-traversing code: Pierre Letouzey *)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Term
@@ -23,6 +23,7 @@ open Declarations
 open Mod_subst
 open Globnames
 open Printer
+open Context.Named.Declaration
 
 (** For a constant c in a module sealed by an interface (M:T and
     not M<:T), [Global.lookup_constant] may return a [constant_body]
@@ -141,22 +142,20 @@ let label_of = function
   | ConstructRef ((kn,_),_) -> pi3 (repr_mind kn)
   | VarRef id -> Label.of_id id
 
-let push (r : Context.rel_declaration) (ctx : Context.rel_context) = r :: ctx
-
 let rec traverse current ctx accu t = match kind_of_term t with
 | Var id ->
-  let body () = match Global.lookup_named id with (_, body, _) -> body in
+  let body () = Global.lookup_named id |> get_value in
   traverse_object accu body (VarRef id)
 | Const (kn, _) ->
   let body () = Global.body_of_constant_body (lookup_constant kn) in
   traverse_object accu body (ConstRef kn)
-| Ind (ind, _) ->
-  traverse_object accu (fun () -> None) (IndRef ind)
-| Construct (cst, _) ->
-  traverse_object accu (fun () -> None) (ConstructRef cst)
+| Ind ((mind, _) as ind, _) ->
+  traverse_inductive accu mind (IndRef ind)
+| Construct (((mind, _), _) as cst, _) ->
+  traverse_inductive accu mind (ConstructRef cst)
 | Meta _ | Evar _ -> assert false
 | Case (_,oty,c,[||]) ->
-    (* non dependent match on an inductive with no constructors *) 
+    (* non dependent match on an inductive with no constructors *)
     begin match Constr.(kind oty, kind c) with
     | Lambda(_,_,oty), Const (kn, _)
       when Vars.noccurn 1 oty &&
@@ -165,9 +164,11 @@ let rec traverse current ctx accu t = match kind_of_term t with
         traverse_object
           ~inhabits:(current,ctx,Vars.subst1 mkProp oty) accu body (ConstRef kn)
     | _ ->
-        Termops.fold_constr_with_full_binders push (traverse current) ctx accu t
+        Termops.fold_constr_with_full_binders
+          Context.Rel.add (traverse current) ctx accu t
     end
-| _ -> Termops.fold_constr_with_full_binders push (traverse current) ctx accu t
+| _ -> Termops.fold_constr_with_full_binders
+          Context.Rel.add (traverse current) ctx accu t
 
 and traverse_object ?inhabits (curr, data, ax2ty) body obj =
   let data, ax2ty =
@@ -185,14 +186,87 @@ and traverse_object ?inhabits (curr, data, ax2ty) body obj =
     | Some body ->
       if already_in then data, ax2ty else
       let contents,data,ax2ty =
-        traverse (label_of obj) [] (Refset_env.empty,data,ax2ty) body in
+        traverse (label_of obj) Context.Rel.empty
+                 (Refset_env.empty,data,ax2ty) body in
       Refmap_env.add obj contents data, ax2ty
   in
   (Refset_env.add obj curr, data, ax2ty)
 
+(** Collects the references occurring in the declaration of mutual inductive
+    definitions. All the constructors and names of a mutual inductive
+    definition share exactly the same dependencies. Also, there is no explicit
+    dependency between mutually defined inductives and constructors. *)
+and traverse_inductive (curr, data, ax2ty) mind obj =
+  let firstind_ref = (IndRef (mind, 0)) in
+  let label = label_of obj in
+  let data, ax2ty =
+   (* Invariant : I_0 \in data iff I_i \in data iff c_ij \in data
+      where I_0, I_1, ... are in the same mutual definition and c_ij
+      are all their constructors. *)
+   if Refmap_env.mem firstind_ref data then data, ax2ty else
+     let mib = Global.lookup_mind mind in
+     (* Collects references of parameters *)
+     let param_ctx = mib.mind_params_ctxt in
+     let nparam = List.length param_ctx in
+     let accu =
+       traverse_context label Context.Rel.empty
+                        (Refset_env.empty, data, ax2ty) param_ctx
+     in
+     (* Build the context of all arities *)
+     let arities_ctx =
+       let global_env = Global.env () in
+       Array.fold_left (fun accu oib ->
+          let pspecif = Univ.in_punivs (mib, oib) in
+          let ind_type = Inductive.type_of_inductive global_env pspecif in
+          let ind_name = Name oib.mind_typename in
+          Context.Rel.add (Context.Rel.Declaration.LocalAssum (ind_name, ind_type)) accu)
+          Context.Rel.empty mib.mind_packets
+     in
+     (* For each inductive, collects references in their arity and in the type
+        of constructors*)
+     let (contents, data, ax2ty) = Array.fold_left (fun accu oib ->
+         let arity_wo_param =
+           List.rev (List.skipn nparam (List.rev oib.mind_arity_ctxt))
+         in
+         let accu =
+           traverse_context
+             label param_ctx accu arity_wo_param
+         in
+         Array.fold_left (fun accu cst_typ ->
+            let param_ctx, cst_typ_wo_param = Term.decompose_prod_n_assum nparam cst_typ in
+            let ctx = Context.(Rel.fold_outside Context.Rel.add ~init:arities_ctx param_ctx) in
+            traverse label ctx accu cst_typ_wo_param)
+          accu oib.mind_user_lc)
+       accu mib.mind_packets
+     in
+     (* Maps all these dependencies to inductives and constructors*)
+     let data = Array.fold_left_i (fun n data oib ->
+       let ind = (mind, n) in
+       let data = Refmap_env.add (IndRef ind) contents data in
+       Array.fold_left_i (fun k data _ ->
+         Refmap_env.add (ConstructRef (ind, k+1)) contents data
+       ) data oib.mind_consnames) data mib.mind_packets
+     in
+     data, ax2ty
+  in
+  (Refset_env.add obj curr, data, ax2ty)
+
+(** Collects references in a rel_context. *)
+and traverse_context current ctx accu ctxt =
+  snd (Context.Rel.fold_outside (fun decl (ctx, accu) ->
+    match decl with
+     | Context.Rel.Declaration.LocalDef (_,c,t) ->
+          let accu = traverse current ctx (traverse current ctx accu t) c in
+          let ctx = Context.Rel.add decl ctx in
+          ctx, accu
+     | Context.Rel.Declaration.LocalAssum (_,t) ->
+          let accu = traverse current ctx accu t in
+          let ctx = Context.Rel.add decl ctx in
+           ctx, accu) ctxt ~init:(ctx, accu))
+
 let traverse current t =
   let () = modcache := MPmap.empty in
-  traverse current [] (Refset_env.empty, Refmap_env.empty, Refmap_env.empty) t
+  traverse current Context.Rel.empty (Refset_env.empty, Refmap_env.empty, Refmap_env.empty) t
 
 (** Hopefully bullet-proof function to recover the type of a constant. It just
     ignores all the universe stuff. There are many issues that can arise when
@@ -208,15 +282,23 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t =
   let (_, graph, ax2ty) = traverse (label_of gr) t in
   let fold obj _ accu = match obj with
   | VarRef id ->
-    let (_, body, t) = Global.lookup_named id in
-    if Option.is_empty body then ContextObjectMap.add (Variable id) t accu
+    let decl = Global.lookup_named id in
+    if is_local_assum decl then
+      let t = Context.Named.Declaration.get_type decl in
+      ContextObjectMap.add (Variable id) t accu
     else accu
   | ConstRef kn ->
-    let cb = lookup_constant kn in
-    if not (Declareops.constant_has_body cb) then
+      let cb = lookup_constant kn in
+      let accu =
+        if cb.const_typing_flags.check_guarded then accu
+        else
+          let l = try Refmap_env.find obj ax2ty with Not_found -> [] in
+          ContextObjectMap.add (Axiom (Guarded kn, l)) Constr.mkProp accu
+      in
+    if not (Declareops.constant_has_body cb) || not cb.const_typing_flags.check_universes then
       let t = type_of_constant cb in
       let l = try Refmap_env.find obj ax2ty with Not_found -> [] in
-      ContextObjectMap.add (Axiom (kn,l)) t accu
+      ContextObjectMap.add (Axiom (Constant kn,l)) t accu
     else if add_opaque && (Declareops.is_opaque cb || not (Cpred.mem kn knst)) then
       let t = type_of_constant cb in
       ContextObjectMap.add (Opaque kn) t accu
@@ -225,6 +307,12 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t =
       ContextObjectMap.add (Transparent kn) t accu
     else
       accu
-  | IndRef _ | ConstructRef _ -> accu
+  | IndRef (m,_) | ConstructRef ((m,_),_) ->
+      let mind = Global.lookup_mind m in
+      if mind.mind_typing_flags.check_guarded then
+        accu
+      else
+        let l = try Refmap_env.find obj ax2ty with Not_found -> [] in
+        ContextObjectMap.add (Axiom (Positive m, l)) Constr.mkProp accu
   in
   Refmap_env.fold fold graph ContextObjectMap.empty
diff --git a/toplevel/assumptions.mli b/toplevel/assumptions.mli
index 666218fe..07267578 100644
--- a/toplevel/assumptions.mli
+++ b/toplevel/assumptions.mli
@@ -6,7 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Util
 open Names
 open Term
 open Globnames
@@ -22,7 +21,7 @@ open Printer
 val traverse :
   Label.t -> constr ->
     (Refset_env.t * Refset_env.t Refmap_env.t *
-     (label * Context.rel_context * types) list Refmap_env.t)
+     (label * Context.Rel.t * types) list Refmap_env.t)
 
 (** Collects all the assumptions (optionally including opaque definitions)
    on which a term relies (together with their type). The above warning of
diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml
index b3144fa9..0561fc4b 100644
--- a/toplevel/auto_ind_decl.ml
+++ b/toplevel/auto_ind_decl.ml
@@ -10,7 +10,7 @@
    decidable equality, created by Vincent Siles, Oct 2007 *)
 
 open Tacmach
-open Errors
+open CErrors
 open Util
 open Pp
 open Term
@@ -25,6 +25,7 @@ open Tactics
 open Ind_tables
 open Misctypes
 open Proofview.Notations
+open Context.Rel.Declaration
 
 let out_punivs = Univ.out_punivs
 
@@ -53,7 +54,7 @@ exception EqUnknown of string
 exception UndefinedCst of string
 exception InductiveWithProduct
 exception InductiveWithSort
-exception ParameterWithoutEquality of constant
+exception ParameterWithoutEquality of global_reference
 exception NonSingletonProp of inductive
 exception DecidabilityMutualNotSupported
 
@@ -85,7 +86,7 @@ let destruct_on c = destruct false None c None None
 
 let destruct_on_using c id =
   destruct false None c
-    (Some (dl,[[dl,IntroNaming IntroAnonymous];
+    (Some (dl,IntroOrPattern [[dl,IntroNaming IntroAnonymous];
                [dl,IntroNaming (IntroIdentifier id)]]))
     None
 
@@ -102,12 +103,12 @@ let mkFullInd (ind,u) n =
     context_chop (nparams-nparrec) mib.mind_params_ctxt in
   if nparrec > 0
     then mkApp (mkIndU (ind,u),
-      Array.of_list(extended_rel_list (nparrec+n) lnamesparrec))
+      Array.of_list(Context.Rel.to_extended_list (nparrec+n) lnamesparrec))
     else mkIndU (ind,u)
 
 let check_bool_is_defined () =
   try let _ = Global.type_of_global_unsafe Coqlib.glob_bool in ()
-  with e when Errors.noncritical e -> raise (UndefinedCst "bool")
+  with e when CErrors.noncritical e -> raise (UndefinedCst "bool")
 
 let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined")
 
@@ -137,7 +138,7 @@ let build_beq_scheme mode kn =
         | 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 ext_rel_list = Context.Rel.to_extended_list 0 lnamesparrec in
       let lift_cnt = ref 0 in
       let eqs_typ = List.map (fun aa ->
                                 let a = lift !lift_cnt aa in
@@ -146,17 +147,17 @@ let build_beq_scheme mode kn =
                              ) ext_rel_list in
 
         let eq_input = List.fold_left2
-          ( fun a b (n,_,_) -> (* mkLambda(n,b,a) ) *)
+          ( fun a b decl -> (* mkLambda(n,b,a) ) *)
                 (* here I leave the Naming thingy so that the type of
                   the function is more readable for the user *)
-                mkNamedLambda (eqName n) b a )
+                mkNamedLambda (eqName (get_name decl)) b a )
                 c (List.rev eqs_typ) lnamesparrec
        in
-        List.fold_left (fun a (n,_,t) ->(* mkLambda(n,t,a)) eq_input rel_list *)
+        List.fold_left (fun a decl ->(* 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")
-                t  a) eq_input lnamesparrec
+                (match get_name decl with Name s -> s | Anonymous ->  Id.of_string "A")
+                (get_type decl)  a) eq_input lnamesparrec
  in
  let make_one_eq cur =
   let u = Univ.Instance.empty in
@@ -180,7 +181,13 @@ let build_beq_scheme mode kn =
 	let (c,a) = Reductionops.whd_betaiota_stack Evd.empty c in
 	match kind_of_term c with
         | Rel x -> mkRel (x-nlist+ndx), Safe_typing.empty_private_constants
-        | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x))), Safe_typing.empty_private_constants
+        | Var x ->
+          let eid = id_of_string ("eq_"^(string_of_id x)) in
+          let () =
+            try ignore (Environ.lookup_named eid env)
+            with Not_found -> raise (ParameterWithoutEquality (VarRef x))
+          in
+          mkVar eid, Safe_typing.empty_private_constants
         | Cast (x,_,_) -> aux (applist (x,a))
         | App _ -> assert false
         | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> 
@@ -208,7 +215,7 @@ let build_beq_scheme mode kn =
         | LetIn _ -> raise (EqUnknown "LetIn")
         | Const kn ->
 	    (match Environ.constant_opt_value_in env kn with
-	      | None -> raise (ParameterWithoutEquality (fst kn))
+	      | None -> raise (ParameterWithoutEquality (ConstRef (fst kn)))
 	      | Some c -> aux (applist (c,a)))
         | Proj _ -> raise (EqUnknown "Proj")
         | Construct _ -> raise (EqUnknown "Construct")
@@ -233,7 +240,7 @@ let build_beq_scheme mode kn =
                Cn => match Y with ... end |]  part *)
     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
+      Context.Rel.to_extended_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.make n (Lazy.force ff) in
@@ -248,7 +255,7 @@ let build_beq_scheme mode kn =
                     | 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 cc = get_type (List.nth constrsi.(i).cs_args ndx) in
                           let eqA, eff' = compute_A_equality rel_list
                                           nparrec
                                           (nparrec+3+2*nb_cstr_args)
@@ -267,14 +274,14 @@ let build_beq_scheme mode kn =
                           (Array.sub eqs 1 (nb_cstr_args - 1))
                   )
    		  in
-		    (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) cc
+		    (List.fold_left (fun a decl -> mkLambda (get_name decl, get_type decl, a)) cc
                     (constrsj.(j).cs_args)
 		)
-	      else ar2.(j) <- (List.fold_left (fun a (p,q,r) ->
-			mkLambda (p,r,a)) (Lazy.force ff) (constrsj.(j).cs_args) )
+	      else ar2.(j) <- (List.fold_left (fun a decl ->
+			mkLambda (get_name decl, get_type decl, a)) (Lazy.force ff) (constrsj.(j).cs_args) )
 	    done;
 
-	  ar.(i) <- (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a))
+	  ar.(i) <- (List.fold_left (fun a decl -> mkLambda (get_name decl, get_type decl, a))
 			(mkCase (ci,do_predicate rel_list nb_cstr_args,
 				  mkVar (Id.of_string "Y") ,ar2))
 			 (constrsi.(i).cs_args))
@@ -343,7 +350,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q =
                    (str "Var " ++ pr_id s ++ str " seems unknown.")
       )
     in mkVar (find 1)
-  with e when Errors.noncritical e ->
+  with e when CErrors.noncritical e ->
       (* if this happen then the args have to be already declared as a
               Parameter*)
       (
@@ -354,7 +361,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q =
         )))
       )
   in
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
     let type_of_pq = Tacmach.New.of_old (fun gl -> pf_unsafe_type_of gl p) gl in
     let u,v = destruct_ind type_of_pq
     in let lb_type_of_p =
@@ -384,7 +391,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q =
            Tacticals.New.tclTHENLIST [
              Proofview.tclEFFECTS eff;
              Equality.replace p q ; apply app ; Auto.default_auto]
-  end
+  end }
 
 (* used in the bool -> leib side *)
 let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt =
@@ -401,7 +408,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt =
                    (str "Var " ++ pr_id s ++ str " seems unknown.")
       )
     in mkVar (find 1)
-  with e when Errors.noncritical e ->
+  with e when CErrors.noncritical e ->
       (* if this happen then the args have to be already declared as a
          Parameter*)
       (
@@ -416,13 +423,13 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt =
   let rec aux l1 l2 =
     match (l1,l2) with
     | (t1::q1,t2::q2) ->
-        Proofview.Goal.enter begin fun gl ->
+        Proofview.Goal.enter { enter = begin fun gl ->
         let tt1 = Tacmach.New.pf_unsafe_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 -> indu,[||]
+                with e when CErrors.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 (
@@ -457,7 +464,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt =
                   aux q1 q2 ]
               )
         )
-        end
+        end }
     | ([],[]) -> Proofview.tclUNIT ()
     | _ -> Tacticals.New.tclZEROMSG (str "Both side of the equality must have the same arity.")
   in
@@ -487,8 +494,8 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt =
   create, from a list of ids [i1,i2,...,in] the list
   [(in,eq_in,in_bl,in_al),,...,(i1,eq_i1,i1_bl_i1_al  )]
 *)
-let list_id l = List.fold_left ( fun a (n,_,t) -> let s' =
-      match n with
+let list_id l = List.fold_left ( fun a decl -> let s' =
+      match get_name decl with
         Name s -> Id.to_string s
       | Anonymous -> "A" in
           (Id.of_string s',Id.of_string ("eq_"^s'),
@@ -535,9 +542,9 @@ let compute_bl_goal ind lnamesparrec nparrec =
       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")
-                t  a) eq_input lnamesparrec
+      List.fold_left (fun a decl -> mkNamedProd
+                (match get_name decl with Name s -> s | Anonymous ->  Id.of_string "A")
+                (get_type decl) a) eq_input lnamesparrec
     in
       let n = Id.of_string "x" and
           m = Id.of_string "y" in
@@ -564,7 +571,7 @@ let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec =
           avoid := fresh::(!avoid); fresh
         end gl
       in
-      Proofview.Goal.nf_enter begin fun gl ->
+      Proofview.Goal.nf_enter { 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
@@ -580,25 +587,25 @@ let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec =
                      Tacticals.New.tclTRY (
                       Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None)
                      );
-                     Proofview.V82.tactic (simpl_in_hyp (freshz,Locus.InHyp));
+                     simpl_in_hyp (freshz,Locus.InHyp);
 (*
 repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]).
 *)
                     Tacticals.New.tclREPEAT (
                       Tacticals.New.tclTHENLIST [
                          Simple.apply_in freshz (andb_prop());
-                         Proofview.Goal.nf_enter begin fun gl ->
+                         Proofview.Goal.nf_enter { enter = begin fun gl ->
                            let fresht = fresh_id (Id.of_string "Z") gl in
-                            (destruct_on_as (mkVar freshz)
-                                  [[dl,IntroNaming (IntroIdentifier fresht);
+                            destruct_on_as (mkVar freshz)
+                                  (IntroOrPattern [[dl,IntroNaming (IntroIdentifier fresht);
                                     dl,IntroNaming (IntroIdentifier freshz)]])
-                         end
+                         end }
                         ]);
 (*
   Ci a1 ... an = Ci b1 ... bn
  replace bi with ai; auto || replace bi with ai by  apply typeofbi_prod ; auto
 *)
-                      Proofview.Goal.nf_enter begin fun gls ->
+                      Proofview.Goal.nf_enter { enter = begin fun gls ->
                         let gl = Proofview.Goal.concl gls in
                         match (kind_of_term gl) with
                         | App (c,ca) -> (
@@ -617,10 +624,10 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]).
                           | _ -> Tacticals.New.tclZEROMSG (str" Failure while solving Boolean->Leibniz.")
                         )
                         | _ -> Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.")
-                      end
+                      end }
 
                     ]
-      end
+      end }
 
 let bl_scheme_kind_aux = ref (fun _ -> failwith "Undefined")
 
@@ -678,9 +685,9 @@ let compute_lb_goal ind lnamesparrec nparrec =
       let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b ->
         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")
-                t  a) eq_input lnamesparrec
+      List.fold_left (fun a decl -> mkNamedProd
+                (match (get_name decl) with Name s -> s | Anonymous ->  Id.of_string "A")
+                (get_type decl)  a) eq_input lnamesparrec
     in
       let n = Id.of_string "x" and
           m = Id.of_string "y" in
@@ -707,7 +714,7 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec =
           avoid := fresh::(!avoid); fresh
         end gl
       in
-      Proofview.Goal.nf_enter begin fun gl ->
+      Proofview.Goal.nf_enter { 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
@@ -724,13 +731,13 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec =
                       Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None)
                      );
                      Equality.inj None false None (mkVar freshz,NoBindings);
-		     intros; (Proofview.V82.tactic simpl_in_concl);
+		     intros; simpl_in_concl;
                      Auto.default_auto;
                      Tacticals.New.tclREPEAT (
                       Tacticals.New.tclTHENLIST [apply (andb_true_intro());
                                   simplest_split ;Auto.default_auto ]
                       );
-                      Proofview.Goal.nf_enter begin fun gls ->
+                      Proofview.Goal.nf_enter { 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
@@ -746,9 +753,9 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec =
                         )
                         | _ ->
                             Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.")
-                      end
+                      end }
                     ]
-      end
+      end }
 
 let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined")
 
@@ -779,7 +786,7 @@ let _ = lb_scheme_kind_aux := fun () -> lb_scheme_kind
 
 let check_not_is_defined () =
   try ignore (Coqlib.build_coq_not ())
-  with e when Errors.noncritical e -> raise (UndefinedCst "not")
+  with e when CErrors.noncritical e -> raise (UndefinedCst "not")
 
 (* {n=m}+{n<>m}  part  *)
 let compute_dec_goal ind lnamesparrec nparrec =
@@ -819,9 +826,9 @@ let compute_dec_goal ind lnamesparrec nparrec =
       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")
-                t  a) eq_input lnamesparrec
+      List.fold_left (fun a decl -> mkNamedProd
+                (match get_name decl with Name s -> s | Anonymous ->  Id.of_string "A")
+                (get_type decl) a) eq_input lnamesparrec
     in
       let n = Id.of_string "x" and
           m = Id.of_string "y" in
@@ -854,7 +861,7 @@ let compute_dec_tact ind lnamesparrec nparrec =
       avoid := fresh::(!avoid); fresh
     end gl
   in
-  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.Goal.nf_enter { 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
@@ -885,7 +892,7 @@ let compute_dec_tact ind lnamesparrec nparrec =
 	)
 	  (Tacticals.New.tclTHEN (destruct_on eqbnm) Auto.default_auto);
 
-        Proofview.Goal.nf_enter begin fun gl ->
+        Proofview.Goal.nf_enter { enter = begin fun gl ->
           let freshH2 = fresh_id (Id.of_string "H") gl in
 	  Tacticals.New.tclTHENS (destruct_on_using (mkVar freshH) freshH2) [
 	    (* left *)
@@ -897,11 +904,11 @@ let compute_dec_tact ind lnamesparrec nparrec =
             ;
 
 	    (*right *)
-            Proofview.Goal.nf_enter begin fun gl ->
+            Proofview.Goal.nf_enter { enter = begin fun gl ->
             let freshH3 = fresh_id (Id.of_string "H") gl in
             Tacticals.New.tclTHENLIST [
 	      simplest_right ;
-              Proofview.V82.tactic (unfold_constr (Lazy.force Coqlib.coq_not_ref));
+              unfold_constr (Lazy.force Coqlib.coq_not_ref);
               intro;
               Equality.subst_all ();
               assert_by (Name freshH3)
@@ -919,11 +926,11 @@ let compute_dec_tact ind lnamesparrec nparrec =
                               true;
               Equality.discr_tac false None
 	    ]
-            end
+            end }
 	  ]
-        end
+        end }
   ]
-  end
+  end }
 
 let make_eq_decidability mode mind =
   let mib = Global.lookup_mind mind in
diff --git a/toplevel/auto_ind_decl.mli b/toplevel/auto_ind_decl.mli
index b6c66a1e..fa5c6148 100644
--- a/toplevel/auto_ind_decl.mli
+++ b/toplevel/auto_ind_decl.mli
@@ -21,7 +21,7 @@ exception EqUnknown of string
 exception UndefinedCst of string
 exception InductiveWithProduct
 exception InductiveWithSort
-exception ParameterWithoutEquality of constant
+exception ParameterWithoutEquality of Globnames.global_reference
 exception NonSingletonProp of inductive
 exception DecidabilityMutualNotSupported
 
diff --git a/toplevel/class.ml b/toplevel/class.ml
index 3d6d567c..6d53ec9d 100644
--- a/toplevel/class.ml
+++ b/toplevel/class.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Pp
 open Names
@@ -32,7 +32,6 @@ type coercion_error_kind =
   | NotAFunction
   | NoSource of cl_typ option
   | ForbiddenSourceClass of cl_typ
-  | NotUniform
   | NoTarget
   | WrongTarget of cl_typ * cl_typ
   | NotAClass of global_reference
@@ -51,9 +50,6 @@ let explain_coercion_error g = function
       (str ": cannot find the source class of " ++ Printer.pr_global g)
   | ForbiddenSourceClass cl ->
       pr_class cl ++ str " cannot be a source class"
-  | NotUniform ->
-      (Printer.pr_global g ++
-         str" does not respect the uniform inheritance condition");
   | NoTarget ->
       (str"Cannot find the target class")
   | WrongTarget (clt,cl) ->
@@ -197,13 +193,13 @@ let build_id_coercion idf_opt source poly =
   let val_f =
     it_mkLambda_or_LetIn
       (mkLambda (Name Namegen.default_dependent_ident,
-		 applistc vs (extended_rel_list 0 lams),
+		 applistc vs (Context.Rel.to_extended_list 0 lams),
 		 mkRel 1))
        lams
   in
   let typ_f =
     it_mkProd_wo_LetIn
-      (mkProd (Anonymous, applistc vs (extended_rel_list 0 lams), lift 1 t))
+      (mkProd (Anonymous, applistc vs (Context.Rel.to_extended_list 0 lams), lift 1 t))
       lams
   in
   (* juste pour verification *)
@@ -247,6 +243,12 @@ booleen "coercion identite'?"
 lorque source est None alors target est None aussi.
 *)
 
+let warn_uniform_inheritance =
+  CWarnings.create ~name:"uniform-inheritance" ~category:"typechecker"
+         (fun g ->
+          Printer.pr_global g ++
+            strbrk" does not respect the uniform inheritance condition")
+
 let add_new_coercion_core coef stre poly source target isid =
   check_source source;
   let t = Global.type_of_global_unsafe coef in
@@ -262,7 +264,7 @@ let add_new_coercion_core coef stre poly source target isid =
   in
   check_source (Some cls);
   if not (uniform_cond (llp-ind) lvs) then
-    msg_warning (explain_coercion_error coef NotUniform);
+    warn_uniform_inheritance coef;
   let clt =
     try
       get_target tg ind
@@ -310,7 +312,7 @@ let add_coercion_hook poly local ref =
   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
+  Flags.if_verbose Feedback.msg_info msg
 
 let add_coercion_hook poly = Lemmas.mk_hook (add_coercion_hook poly)
 
diff --git a/toplevel/classes.ml b/toplevel/classes.ml
index 3a0b5f24..1528cbb2 100644
--- a/toplevel/classes.ml
+++ b/toplevel/classes.ml
@@ -12,7 +12,7 @@ open Term
 open Vars
 open Environ
 open Nametab
-open Errors
+open CErrors
 open Util
 open Typeclasses_errors
 open Typeclasses
@@ -20,6 +20,8 @@ open Libnames
 open Globnames
 open Constrintern
 open Constrexpr
+open Sigma.Notations
+open Context.Rel.Declaration
 (*i*)
 
 open Decl_kinds
@@ -44,25 +46,34 @@ let set_typeclass_transparency c local b =
     
 let _ =
   Hook.set Typeclasses.add_instance_hint_hook
-    (fun inst path local pri poly ->
+    (fun inst path local info poly ->
      let inst' = match inst with IsConstr c -> Hints.IsConstr (c, Univ.ContextSet.empty)
        | IsGlobal gr -> Hints.IsGlobRef gr
      in
-      Flags.silently (fun () ->
+     let info =
+       let open Vernacexpr in
+       { info with hint_pattern =
+		   Option.map
+		     (Constrintern.intern_constr_pattern (Global.env()))
+		     info.hint_pattern } in
+     Flags.silently (fun () ->
 	Hints.add_hints local [typeclasses_db]
 	  (Hints.HintsResolveEntry
-	     [pri, poly, false, Hints.PathHints path, inst'])) ());
+	     [info, 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))
-        
+
+open Vernacexpr
+
 (** TODO: add subinstances *)
-let existing_instance glob g pri =
+let existing_instance glob g info =
   let c = global g in
+  let info = Option.default Hints.empty_hint_info info 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,u), _)) -> add_instance (new_instance tc pri glob 
+      | Some (_, ((tc,u), _)) -> add_instance (new_instance tc info 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.")
@@ -74,14 +85,14 @@ let mismatched_props env n m = mismatched_ctx_inst env Properties n m
 
 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
+    decl :: ctx ->
+      let t' = substl subst (get_type decl) in
       let c', l =
-	match b with
-	| None -> interp_casted_constr_evars env evars (List.hd l) t', List.tl l
-	| Some b -> substl subst b, l
+	match decl with
+	| LocalAssum _ -> interp_casted_constr_evars env evars (List.hd l) t', List.tl l
+	| LocalDef (_,b,_) -> substl subst b, l
       in
-      let d = na, Some c', t' in
+      let d = get_name decl, Some c', t' in
 	aux (c' :: subst, d :: instctx) l ctx
     | [] -> subst
   in aux (subst, []) inst (List.rev ctx)
@@ -96,37 +107,41 @@ let id_of_class cl =
 
 open Pp
 
-let instance_hook k pri global imps ?hook cst =
+let instance_hook k info global imps ?hook cst =
   Impargs.maybe_declare_manual_implicits false cst ~enriching:false imps;
-  Typeclasses.declare_instance pri (not global) cst;
+  Typeclasses.declare_instance (Some info) (not global) cst;
   (match hook with Some h -> h cst | None -> ())
 
-let declare_instance_constant k pri global imps ?hook id poly uctx term termtype =
+let declare_instance_constant k info global imps ?hook id pl poly evm term termtype =
   let kind = IsDefinition Instance in
-  let uctx = 
+  let evm = 
     let levels = Univ.LSet.union (Universes.universes_of_constr termtype) 
 				 (Universes.universes_of_constr term) in
-      Universes.restrict_universe_context uctx levels 
+    Evd.restrict_universe_context evm levels 
   in
+  let pl, uctx = Evd.universe_context ?names:pl evm in
   let entry = 
-    Declare.definition_entry ~types:termtype ~poly ~univs:(Univ.ContextSet.to_context uctx) term
+    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);
+    Universes.register_universe_binders (ConstRef kn) pl;
+    instance_hook k info global imps ?hook (ConstRef kn);
     id
 
-let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) props
+let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) poly ctx (instid, bk, cl) props
     ?(generalize=true)
     ?(tac:unit Proofview.tactic option) ?hook pri =
   let env = Global.env() in
-  let evars = ref (Evd.from_env env) in
+  let ((loc, instid), pl) = instid in
+  let uctx = Evd.make_evar_universe_context env pl in
+  let evars = ref (Evd.from_ctx uctx) in
   let tclass, ids =
     match bk with
-    | Implicit ->
+    | Decl_kinds.Implicit ->
 	Implicit_quantifiers.implicit_application Id.Set.empty ~allow_partial:false
-	  (fun avoid (clname, (id, _, t)) ->
+	  (fun avoid (clname, _) ->
 	    match clname with
 	    | Some (cl, b) ->
 		let t = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) in
@@ -149,16 +164,17 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro
     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
-	| None -> (List.tl args, List.hd args :: args')
-	| Some b -> (args, substl args' b :: args'))
+      List.fold_right (fun decl (args, args') ->
+        let open Context.Rel.Declaration in
+	match decl with
+	| LocalAssum _ -> (List.tl args, List.hd args :: args')
+	| LocalDef (_,b,_) -> (args, substl args' b :: args'))
 	(snd cl.cl_context) (args, [])
     in
       cl, u, c', ctx', ctx, len, imps, args
   in
   let id =
-    match snd instid with
+    match instid with
 	Name id ->
 	  let sp = Lib.make_path id in
 	    if Nametab.exists_cci sp then
@@ -175,7 +191,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro
     if abstract then
       begin
 	let subst = List.fold_left2
-	  (fun subst' s (_, b, _) -> if Option.is_empty b then s :: subst' else subst')
+	  (fun subst' s decl -> if is_local_assum decl then s :: subst' else subst')
 	  [] subst (snd k.cl_context)
 	in
 	let (_, ty_constr) = instance_constructor (k,u) subst in
@@ -184,17 +200,19 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro
 	  let t = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in
 	    nf t
 	in
-	Evarutil.check_evars env Evd.empty !evars termtype;
-	let pl, ctx = Evd.universe_context !evars in
+	Pretyping.check_evars env Evd.empty !evars termtype;
+	let pl, ctx = Evd.universe_context ?names:pl !evars in
 	let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id
 	  (ParameterEntry 
             (None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical)
-	in instance_hook k None global imps ?hook (ConstRef cst); id
+	in
+	  Universes.register_universe_binders (ConstRef cst) pl;
+	  instance_hook k pri global imps ?hook (ConstRef cst); id
       end
     else (
       let props =
 	match props with
-	| Some (true, CRecord (loc, _, fs)) ->
+	| 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)
@@ -217,10 +235,10 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro
 	    in
 	    let props, rest =
 	      List.fold_left
-		(fun (props, rest) (id,b,_) ->
-		  if Option.is_empty b then 
+		(fun (props, rest) decl ->
+		  if is_local_assum decl then
 		    try
-		      let is_id (id', _) = match id, get_id id' with
+		      let is_id (id', _) = match get_name decl, get_id id' with
 			| Name id, (_, id') -> Id.equal id id'
 			| Anonymous, _ -> false
                       in
@@ -254,7 +272,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro
 	    None, termtype
 	| Some (Inl subst) ->
 	  let subst = List.fold_left2
-	    (fun subst' s (_, b, _) -> if Option.is_empty b then s :: subst' else subst')
+	    (fun subst' s decl -> if is_local_assum decl then s :: subst' else subst')
 	    [] subst (k.cl_props @ snd k.cl_context)
 	  in
 	  let (app, ty_constr) = instance_constructor (k,u) subst in
@@ -278,20 +296,19 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro
       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
+	Pretyping.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_set 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
+	  declare_instance_constant k pri global imps ?hook id pl
+            poly evm (Option.get term) termtype
+	else if Flags.is_program_mode () || refine || 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)
+		  Typeclasses.declare_instance (Some pri) (not global) (ConstRef cst)
 	      in
 	      let obls, constr, typ =
 		match term with 
@@ -304,7 +321,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro
               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);
+ 			?pl typ ctx ~kind:(Global,poly,Instance) ~hook obls);
 		id
 	    else
 	      (Flags.silently 
@@ -322,7 +339,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro
 		if not (Option.is_empty term) then
                   let init_refine =
                     Tacticals.New.tclTHENLIST [
-                      Proofview.Refine.refine (fun evm -> evm, Option.get term);
+                      Refine.refine { run = fun evm -> Sigma (Option.get term, evm, Sigma.refl) };
                       Proofview.Unsafe.tclNEWGOALS gls;
                       Tactics.New.reduce_after_refine;
                     ]
@@ -333,14 +350,16 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro
 		(match tac with Some tac -> ignore (Pfedit.by tac) | None -> ())) ();
 	       id)
 	end
-      else Errors.error "Unsolved obligations remaining.")
+      else CErrors.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 -> invalid_arg "named_of_rel_context" | Name id -> id in
-	let d = (id, Option.map (substl subst) b, substl subst t) in
+      (fun decl (subst, ctx) ->
+        let id = match get_name decl with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in
+	let d = match decl with
+	  | LocalAssum (_,t) -> id, None, substl subst t
+	  | LocalDef (_,b,t) -> id, Some (substl subst b), substl subst t in
 	  (mkVar id :: subst, d :: ctx))
       l ([], [])
   in ctx
@@ -350,12 +369,12 @@ let context poly l =
   let evars = ref (Evd.from_env env) 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
-  let () = List.iter (fun (n, b, t) -> Option.iter ce b; ce t) fullctx in
+  let fullctx = Context.Rel.map subst fullctx in
+  let ce t = Pretyping.check_evars env Evd.empty !evars t in
+  let () = List.iter (fun decl -> Context.Rel.Declaration.iter_constr ce decl) fullctx in
   let ctx =
     try named_of_rel_context fullctx
-    with e when Errors.noncritical e ->
+    with e when CErrors.noncritical e ->
       error "Anonymous variables not allowed in contexts."
   in
   let uctx = ref (Evd.universe_context_set !evars) in
@@ -368,7 +387,7 @@ let context poly l =
       let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id decl in
 	match class_of_constr t with
 	| Some (rels, ((tc,_), args) as _cl) ->
-	    add_instance (Typeclasses.new_instance tc None false (*FIXME*)
+	    add_instance (Typeclasses.new_instance tc Hints.empty_hint_info false (*FIXME*)
 			    poly (ConstRef cst));
             status
 	    (* declare_subclasses (ConstRef cst) cl *)
diff --git a/toplevel/classes.mli b/toplevel/classes.mli
index 24c51b31..d2cb788e 100644
--- a/toplevel/classes.mli
+++ b/toplevel/classes.mli
@@ -7,7 +7,6 @@
 (************************************************************************)
 
 open Names
-open Context
 open Environ
 open Constrexpr
 open Typeclasses
@@ -15,24 +14,25 @@ open Libnames
 
 (** Errors *)
 
-val mismatched_params : env -> constr_expr list -> rel_context -> 'a
+val mismatched_params : env -> constr_expr list -> Context.Rel.t -> 'a
 
-val mismatched_props : env -> constr_expr list -> rel_context -> 'a
+val mismatched_props : env -> constr_expr list -> Context.Rel.t -> 'a
 
 (** Instance declaration *)
 
-val existing_instance : bool -> reference -> int option -> unit
-(** globality, reference, priority *)
+val existing_instance : bool -> reference -> Vernacexpr.hint_info_expr option -> unit
+(** globality, reference, optional priority and pattern information *)
 
 val declare_instance_constant :
   typeclass ->
-  int option -> (** priority *)
+  Vernacexpr.hint_info_expr -> (** priority *)
   bool -> (** globality *)
   Impargs.manual_explicitation list -> (** implicits *)
   ?hook:(Globnames.global_reference -> unit) ->
   Id.t -> (** name *)
+  Id.t Loc.located list option ->
   bool -> (* polymorphic *)
-  Univ.universe_context_set -> (* Universes *)
+  Evd.evar_map -> (* Universes *)
   Constr.t -> (** body *)
   Term.types -> (** type *)
   Names.Id.t
@@ -40,6 +40,7 @@ val declare_instance_constant :
 val new_instance :
   ?abstract:bool -> (** Not abstract by default. *)
   ?global:bool -> (** Not global by default. *)
+  ?refine:bool -> (** Allow refinement *)
   Decl_kinds.polymorphic ->
   local_binder list ->
   typeclass_constraint ->
@@ -47,7 +48,7 @@ val new_instance :
   ?generalize:bool ->
   ?tac:unit Proofview.tactic  ->
   ?hook:(Globnames.global_reference -> unit) ->
-  int option ->
+  Vernacexpr.hint_info_expr ->
   Id.t
 
 (** Setting opacity *)
diff --git a/toplevel/command.ml b/toplevel/command.ml
index 5d2a7638..a9f2598e 100644
--- a/toplevel/command.ml
+++ b/toplevel/command.ml
@@ -7,14 +7,12 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Flags
 open Term
 open Vars
-open Context
 open Termops
-open Entries
 open Environ
 open Redexpr
 open Declare
@@ -37,17 +35,20 @@ open Evarconv
 open Indschemes
 open Misctypes
 open Vernacexpr
+open Sigma.Notations
+open Context.Rel.Declaration
+open Entries
 
 let do_universe poly l = Declare.do_universe poly l
 let do_constraint poly l = Declare.do_constraint poly l
 
 let rec under_binders env sigma f n c =
-  if Int.equal n 0 then snd (f env sigma c) else
+  if Int.equal n 0 then f env sigma c else
     match kind_of_term c with
       | Lambda (x,t,c) ->
-	  mkLambda (x,t,under_binders (push_rel (x,None,t) env) sigma f (n-1) c)
+	  mkLambda (x,t,under_binders (push_rel (LocalAssum (x,t)) env) sigma f (n-1) c)
       | LetIn (x,b,t,c) ->
-	  mkLetIn (x,b,t,under_binders (push_rel (x,Some b,t) env) sigma f (n-1) c)
+	  mkLetIn (x,b,t,under_binders (push_rel (LocalDef (x,b,t)) env) sigma f (n-1) c)
       | _ -> assert false
 
 let rec complete_conclusion a cs = function
@@ -72,11 +73,21 @@ let red_constant_entry n ce sigma = function
   | Some red ->
       let proof_out = ce.const_entry_body in
       let env = Global.env () in
+      let (redfun, _) = reduction_of_red_expr env red in
+      let redfun env sigma c =
+        let sigma = Sigma.Unsafe.of_evar_map sigma in
+        let Sigma (c, _, _) = redfun.e_redfun env sigma c in
+        c
+      in
       { ce with const_entry_body = Future.chain ~greedy:true ~pure:true proof_out
-        (fun ((body,ctx),eff) ->
-          (under_binders env sigma
-             (fst (reduction_of_red_expr env red)) n body,ctx),eff) }
-
+        (fun ((body,ctx),eff) -> (under_binders env sigma redfun n body,ctx),eff) }
+
+let warn_implicits_in_term =
+  CWarnings.create ~name:"implicits-in-term" ~category:"implicits"
+         (fun () ->
+          strbrk "Implicit arguments declaration relies on type." ++ spc () ++
+            strbrk "The term declares more implicits than the type here.")
+        
 let interp_definition pl bl p red_option c ctypopt =
   let env = Global.env() in
   let ctx = Evd.make_evar_universe_context env pl in
@@ -87,7 +98,7 @@ let interp_definition pl bl p red_option c ctypopt =
     match ctypopt with
       None ->
         let subst = evd_comb0 Evd.nf_univ_variables evdref in
-	let ctx = map_rel_context (Vars.subst_univs_constr subst) ctx in
+	let ctx = Context.Rel.map (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
@@ -100,7 +111,7 @@ let interp_definition pl bl p red_option c ctypopt =
     | Some ctyp ->
 	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 ctx = Context.Rel.map (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
@@ -114,9 +125,7 @@ let interp_definition pl bl p red_option c ctypopt =
           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.");
+	then warn_implicits_in_term ();
         let vars = Univ.LSet.union (Universes.universes_of_constr body) 
           (Universes.universes_of_constr typ) in
         let ctx = Evd.restrict_universe_context !evdref vars in
@@ -125,23 +134,27 @@ let interp_definition pl bl p red_option c ctypopt =
 	  definition_entry ~types:typ ~poly:p 
 	    ~univs:uctx body
   in
-  red_constant_entry (rel_context_length ctx) ce !evdref red_option, !evdref, pl, imps
+  red_constant_entry (Context.Rel.length ctx) ce !evdref red_option, !evdref, pl, imps
 
 let check_definition (ce, evd, _, imps) =
   check_evars_are_solved (Global.env ()) evd (Evd.empty,evd);
   ce
 
-let get_locality id = function
+let warn_local_declaration =
+  CWarnings.create ~name:"local-declaration" ~category:"scope"
+         (fun (id,kind) ->
+          pr_id id ++ strbrk " is declared as a local " ++ str kind)
+
+let get_locality id ~kind = 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
+   warn_local_declaration (id,kind);
   true
 | Local -> true
 | Global -> false
 
 let declare_global_definition ident ce local k pl imps =
-  let local = get_locality ident local in
+  let local = get_locality ident ~kind:"definition" local in
   let kn = declare_constant ident ~local (DefinitionEntry ce, IsDefinition k) in
   let gr = ConstRef kn in
   let () = maybe_declare_manual_implicits false gr imps in
@@ -153,6 +166,12 @@ let declare_definition_hook = ref ignore
 let set_declare_definition_hook = (:=) declare_definition_hook
 let get_declare_definition_hook () = !declare_definition_hook
 
+let warn_definition_not_visible =
+  CWarnings.create ~name:"definition-not-visible" ~category:"implicits"
+         (fun ident ->
+          strbrk "Section definition " ++
+            pr_id ident ++ strbrk " is not visible from current goals")
+
 let declare_definition ident (local, p, k) ce pl imps hook =
   let fix_exn = Future.fix_exn_of ce.const_entry_body in
   let () = !declare_definition_hook ce in
@@ -164,9 +183,7 @@ let declare_definition ident (local, p, k) ce pl imps hook =
     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
+	       warn_definition_not_visible ident
     in
     gr
   | Discharge | Local | Global ->
@@ -177,7 +194,9 @@ let _ = Obligations.declare_definition_ref :=
        (fun i k c imps hook -> declare_definition i k c [] imps hook)
 
 let do_definition ident k pl bl red_option c ctypopt hook =
-  let (ce, evd, pl, imps as def) = interp_definition pl bl (pi2 k) red_option c ctypopt in
+  let (ce, evd, pl', imps as def) =
+    interp_definition pl 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
@@ -194,9 +213,9 @@ let do_definition ident k pl bl red_option c ctypopt hook =
       let ctx = Evd.evar_universe_context evd in
       let hook = Lemmas.mk_hook (fun l r _ -> Lemmas.call_hook (fun exn -> exn) hook l r) in
 	ignore(Obligations.add_definition
-          ident ~term:c cty ctx ~implicits:imps ~kind:k ~hook obls)
+          ident ~term:c cty ctx ?pl ~implicits:imps ~kind:k ~hook obls)
     else let ce = check_definition def in
-      ignore(declare_definition ident k ce pl imps
+      ignore(declare_definition ident k ce pl' imps
         (Lemmas.mk_hook
           (fun l r -> Lemmas.call_hook (fun exn -> exn) hook l r;r)))
 
@@ -210,7 +229,7 @@ match local with
   let () = assumption_message ident in
   let () =
     if is_verbose () && Pfedit.refining () then
-    msg_warning (str"Variable" ++ spc () ++ pr_id ident ++
+    Feedback.msg_info (str"Variable" ++ spc () ++ pr_id ident ++
     strbrk " is not visible from current goals")
   in
   let r = VarRef ident in
@@ -219,7 +238,7 @@ match local with
   (r,Univ.Instance.empty,true)
 
 | Global | Local | Discharge ->
-  let local = get_locality ident local in
+  let local = get_locality ident ~kind:"axiom" local in
   let inl = match nl with
     | NoInline -> None
     | DefaultInline -> Some (Flags.get_inline_level())
@@ -242,10 +261,7 @@ match local with
 
 let interp_assumption evdref env impls bl c =
   let c = prod_constr_expr c bl in
-  let ty, impls = interp_type_evars_impls env evdref ~impls c in
-  let evd, nf = nf_evars_and_universes !evdref in
-  let ctx = Evd.universe_context_set evd in
-    ((nf ty, ctx), impls)
+  interp_type_evars_impls env evdref ~impls c
 
 let declare_assumptions idl is_coe k (c,ctx) pl imps impl_is_on nl =
   let refs, status, _ =
@@ -258,6 +274,7 @@ let declare_assumptions idl is_coe k (c,ctx) pl imps impl_is_on nl =
   List.rev refs, status
 
 let do_assumptions_unbound_univs (_, poly, _ as kind) nl l =
+  let open Context.Named.Declaration in
   let env = Global.env () in
   let evdref = ref (Evd.from_env env) in
   let l = 
@@ -269,26 +286,32 @@ let do_assumptions_unbound_univs (_, poly, _ as kind) nl l =
         l []
     else l
   in
+  (* We intepret all declarations in the same evar_map, i.e. as a telescope. *)
   let _,l = List.fold_map (fun (env,ienv) (is_coe,(idl,c)) ->
-    let (t,ctx),imps = interp_assumption evdref env ienv [] c in
+    let t,imps = interp_assumption evdref env ienv [] c in
     let env =
-      push_named_context (List.map (fun (_,id) -> (id,None,t)) idl) env in
+      push_named_context (List.map (fun (_,id) -> LocalAssum (id,t)) idl) env in
     let ienv = List.fold_right (fun (_,id) ienv ->
       let impls = compute_internalization_data env Variable t imps in
       Id.Map.add id impls ienv) idl ienv in
-      ((env,ienv),((is_coe,idl),t,(ctx,imps)))) 
+      ((env,ienv),((is_coe,idl),t,imps))) 
     (env,empty_internalization_env) l
   in
   let evd = solve_remaining_evars all_and_fail_flags env !evdref (Evd.empty,!evdref) in
+  (* The universe constraints come from the whole telescope. *)
+  let evd = Evd.nf_constraints evd in
+  let ctx = Evd.universe_context_set evd 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)) ->
+  pi2 (List.fold_left (fun (subst,status,ctx) ((is_coe,idl),t,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)
+    (subst'@subst, status' && status,
+     (* The universe constraints are declared with the first declaration only. *)
+     Univ.ContextSet.empty)) ([],true,ctx) l)
 
 let do_assumptions_bound_univs coe kind nl id pl c =
   let env = Global.env () in
@@ -334,7 +357,7 @@ let do_assumptions kind nl l = match l with
 (* 3b| Mutual inductive definitions *)
 
 let push_types env idl tl =
-  List.fold_left2 (fun env id t -> Environ.push_rel (Name id,None,t) env)
+  List.fold_left2 (fun env id t -> Environ.push_rel (LocalAssum (Name id,t)) env)
     env idl tl
 
 type structured_one_inductive_expr = {
@@ -377,8 +400,8 @@ let mk_mltype_data evdref env assums arity indname =
   (is_ml_type,indname,assums)
 
 let prepare_param = function
-  | (na,None,t) -> out_name na, LocalAssum t
-  | (na,Some b,_) -> out_name na, LocalDef b
+  | LocalAssum (na,t) -> out_name na, LocalAssumEntry t
+  | LocalDef (na,b,_) -> out_name na, LocalDefEntry b
 
 (** Make the arity conclusion flexible to avoid generating an upper bound universe now,
     only if the universe does not appear anywhere else.
@@ -432,12 +455,12 @@ let interp_cstrs evdref env impls mldata arity ind =
 
 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)))
+    (fun d (lev,env) ->
+      match d with
+      | LocalDef _ -> lev, push_rel d env
+      | LocalAssum _ ->
+	let s = destSort (Reduction.whd_all env 
+			    (nf_evar evd (Retyping.get_type_of env evd (get_type d))))
 	in
 	let u = univ_of_sort s in
 	  (Univ.sup u lev, push_rel d env))
@@ -448,7 +471,7 @@ 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 
+      sign_level env evd (LocalAssum (Anonymous, concl) :: ctx)) tys
   in sup_list min sorts
 
 let is_flexible_sort evd u =
@@ -517,11 +540,9 @@ let inductive_levels env evdref poly arities inds =
 	in
 	let duu = Sorts.univ_of_sort du in
 	let evd =
-	  if not (Univ.is_small_univ duu) && Evd.check_eq evd cu duu then
-	    if is_flexible_sort evd duu then
-	      if Evd.check_leq evd Univ.type0_univ duu then
-	      	evd
-	      else Evd.set_eq_sort env evd (Prop Null) du
+	  if not (Univ.is_small_univ duu) && Univ.Universe.equal cu duu then
+	    if is_flexible_sort evd duu && not (Evd.check_leq evd Univ.type0_univ duu) then
+	      Evd.set_eq_sort env evd (Prop Null) du
 	    else evd
 	  else Evd.set_eq_sort env evd (Type cu) du
 	in
@@ -540,6 +561,7 @@ let check_param = function
 | LocalRawDef (na, _) -> check_named na
 | LocalRawAssum (nas, Default _, _) -> List.iter check_named nas
 | LocalRawAssum (nas, Generalized _, _) -> ()
+| LocalPattern _ -> assert false
 
 let interp_mutual_inductive (paramsl,indl) notations poly prv finite =
   check_all_names_different indl;
@@ -554,8 +576,8 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite =
   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,_) -> Option.is_empty b) ctx_params in
-  let params = List.map (fun (na,_,_) -> out_name na) assums in
+  let assums = List.filter is_local_assum ctx_params in
+  let params = List.map (fun decl -> out_name (get_name decl)) assums in
 
   (* Interpret the arities *)
   let arities = List.map (interp_ind_arity env_params evdref) indl in
@@ -566,7 +588,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite =
 
   (* Compute interpretation metadatas *)
   let indimpls = List.map (fun (_, _, impls) -> userimpls @ 
-    lift_implicits (rel_context_nhyps ctx_params) impls) arities in
+    lift_implicits (Context.Rel.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
@@ -592,11 +614,11 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite =
   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 ctx_params = Context.Rel.map nf ctx_params in
   let evd = !evdref in
   let pl, uctx = Evd.universe_context ?names:pl evd in
   List.iter (check_evars env_params Evd.empty evd) arities;
-  iter_rel_context (check_evars env0 Evd.empty evd) ctx_params;
+  Context.Rel.iter (check_evars env0 Evd.empty evd) ctx_params;
   List.iter (fun (_,ctyps,_) ->
     List.iter (check_evars env_ar_params Evd.empty evd) ctyps)
     constructors;
@@ -610,7 +632,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite =
     mind_entry_lc = ctypes
   }) indl arities aritypoly constructors in
   let impls =
-    let len = rel_context_nhyps ctx_params in
+    let len = Context.Rel.nhyps ctx_params in
       List.map2 (fun indimpls (_,_,cimpls) ->
 	indimpls, List.map (fun impls ->
 	  userimpls @ (lift_implicits len impls)) cimpls) indimpls constructors
@@ -622,7 +644,8 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite =
     mind_entry_inds = entries;
     mind_entry_polymorphic = poly;
     mind_entry_private = if prv then Some false else None;
-    mind_entry_universes = uctx },
+    mind_entry_universes = uctx;
+  },
     pl, impls
 
 (* Very syntactical equality *)
@@ -698,7 +721,7 @@ let declare_mutual_inductive_with_eliminations mie pl impls =
 		constrimpls)
       impls;
   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_verbose Feedback.msg_info (minductive_message warn_prim names);
   if mie.mind_entry_private == None
   then declare_default_schemes mind;
   mind
@@ -716,8 +739,10 @@ let do_mutual_inductive indl poly prv finite =
   (* 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) false poly) coes
-	    
+  List.iter (fun qid -> Class.try_add_new_coercion (locate qid) false poly) coes;
+  (* If positivity is assumed declares itself as unsafe. *)
+  if Environ.deactivated_guard (Global.env ()) then Feedback.feedback Feedback.AddedAxiom else ()
+
 (* 3c| Fixpoints and co-fixpoints *)
 
 (* An (unoptimized) function that maps preorders to partial orders...
@@ -768,20 +793,25 @@ let rec partial_order cmp = function
 let non_full_mutual_message x xge y yge isfix rest =
   let reason =
     if Id.List.mem x yge then
-      pr_id y ++ str " depends on " ++ pr_id x ++ str " but not conversely"
+      pr_id y ++ str " depends on " ++ pr_id x ++ strbrk " but not conversely"
     else if Id.List.mem y xge then
-      pr_id x ++ str " depends on " ++ pr_id y ++ str " but not conversely"
+      pr_id x ++ str " depends on " ++ pr_id y ++ strbrk " but not conversely"
     else
-      pr_id y ++ str " and " ++ pr_id x ++ str " are not mutually dependent" in
-  let e = if List.is_empty rest then reason else str "e.g., " ++ reason in
+      pr_id y ++ str " and " ++ pr_id x ++ strbrk " are not mutually dependent" in
+  let e = if List.is_empty rest then reason else strbrk "e.g., " ++ reason in
   let k = if isfix then "fixpoint" else "cofixpoint" in
   let w =
     if isfix
-    then str "Well-foundedness check may fail unexpectedly." ++ fnl()
+    then strbrk "Well-foundedness check may fail unexpectedly." ++ fnl()
     else mt () in
-  str "Not a fully mutually defined " ++ str k ++ fnl () ++
+  strbrk "Not a fully mutually defined " ++ str k ++ fnl () ++
   str "(" ++ e ++ str ")." ++ fnl () ++ w
 
+let warn_non_full_mutual =
+  CWarnings.create ~name:"non-full-mutual" ~category:"fixpoints"
+         (fun (x,xge,y,yge,isfix,rest) ->
+          non_full_mutual_message x xge y yge isfix rest)
+
 let check_mutuality env isfix fixl =
   let names = List.map fst fixl in
   let preorder =
@@ -791,7 +821,7 @@ let check_mutuality env isfix fixl =
   let po = partial_order Id.equal preorder in
   match List.filter (function (_,Inr _) -> true | _ -> false) po with
     | (x,Inr xge)::(y,Inr yge)::rest ->
-	msg_warning (non_full_mutual_message x xge y yge isfix rest)
+       warn_non_full_mutual (x,xge,y,yge,isfix,rest)
     | _ -> ()
 
 type structured_fixpoint_expr = {
@@ -826,7 +856,7 @@ let declare_fix ?(opaque = false) (_,poly,_ as kind) pl ctx f ((def,_),eff) t im
   declare_definition f kind ce pl imps (Lemmas.mk_hook (fun _ r -> r))
 
 let _ = Obligations.declare_fix_ref :=
-	  (fun ?opaque k ctx f d t imps -> declare_fix ?opaque k [] ctx f d t imps)
+  (fun ?opaque k ctx f d t imps -> declare_fix ?opaque k [] ctx f d t imps)
 
 let prepare_recursive_declaration fixnames fixtypes fixdefs =
   let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in
@@ -868,19 +898,20 @@ 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 sigT = 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 ->
+  | [LocalAssum (n, t)] -> t, [LocalDef (n, mkRel 1, t)], mkRel 1
+  | LocalAssum (n, 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
+	  (fun (ty, tys, (k, constr)) decl ->
+            let t = get_type decl in
+            let pred = mkLambda (get_name decl, 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
@@ -889,26 +920,27 @@ let rec telescope = function
 	  (t, [], (2, mkRel 1)) tl
       in
       let (last, subst) = List.fold_right2
-	(fun pred (n, b, t) (prev, subst) ->
+        (fun pred decl (prev, subst) ->
+          let t = get_type decl in
 	  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))
+	    (lift 1 proj2, LocalDef (get_name decl, proj1, t) :: subst))
 	(List.rev tys) tl (mkRel 1, [])
-      in ty, ((n, Some last, t) :: subst), constr
+      in ty, (LocalDef (n, 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
+  | LocalDef (n, b, t) :: tl -> let ty, subst, term = telescope tl in
+      ty, (LocalDef (n, 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
+  List.map (map_constr (Evarutil.nf_evar sigma)) ctx
 
-let build_wellfounded (recname,n,bl,arityc,body) r measure notation =
+let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation =
   Coqlib.check_required_library ["Coq";"Program";"Wf"];
   let env = Global.env() in
-  let evdref = ref (Evd.from_env env) in
+  let ctx = Evd.make_evar_universe_context env pl in
+  let evdref = ref (Evd.from_ctx ctx) 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
@@ -916,11 +948,10 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation =
   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 arg = LocalAssum (Name argname, 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.unsafe_type_of env !evdref rel in
   let relargty =
     let error () =
@@ -931,10 +962,10 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation =
       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)
+	  | [LocalAssum (_,t); LocalAssum (_,u)], Sort (Prop Null)
 	      when Reductionops.is_conv env !evdref t u -> t
 	  | _, _ -> error ()
-      with e when Errors.noncritical e -> error ()
+      with e when CErrors.noncritical e -> error ()
   in
   let measure = interp_casted_constr_evars binders_env evdref measure relargty in
   let wf_rel, wf_rel_fun, measure_fn =
@@ -951,9 +982,9 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation =
   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))))
+  let wfarg len = LocalAssum (Name argid',
+                              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
@@ -967,22 +998,22 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation =
   (* 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 intern_fun_binder = LocalAssum (Name (add_suffix recname "'"), 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 lam = LocalAssum (Name (Id.of_string "recproof"), 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)
+      LocalDef (Name recname, 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 ctx = LocalAssum (Name recname, get_type curry_fun) :: binders_rel in
     let (r, l, impls, scopes) =
       Constrintern.compute_internalization_data env
 	Constrintern.Recursive full_arity impls 
@@ -1002,7 +1033,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation =
 	       ~src:(Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define false)) wf_proof;
 	     prop |])
   in
-  let def = Typing.solve_evars env evdref def in
+  let def = Typing.e_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
@@ -1014,9 +1045,9 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation =
       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 pl, univs = Evd.universe_context !evdref in
+	let pl, univs = Evd.universe_context ?names:pl !evdref in
 	  (*FIXME poly? *)
-	let ce = definition_entry ~types:ty ~univs (Evarutil.nf_evar !evdref body) in
+	let ce = definition_entry ~poly ~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
@@ -1040,10 +1071,11 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation =
     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 
+    ignore(Obligations.add_definition recname ~term:evars_def ?pl
 	     evars_typ ctx evars ~hook)
 
 let interp_recursive isfix fixl notations =
+  let open Context.Named.Declaration in
   let env = Global.env() in
   let fixnames = List.map (fun fix -> fix.fix_name) fixl in
 
@@ -1056,7 +1088,7 @@ let interp_recursive isfix fixl notations =
         | Some ls , Some us ->
 	   if not (CList.for_all2eq (fun x y -> Id.equal (snd x) (snd y)) ls us) then
 	     error "(co)-recursive definitions should all have the same universe binders";
-	   Some (ls @ us)) fixl None in
+	   Some us) fixl None in
   let ctx = Evd.make_evar_universe_context env all_universes in
   let evdref = ref (Evd.from_ctx ctx) in
   let fixctxs, fiximppairs, fixannots =
@@ -1076,11 +1108,11 @@ let interp_recursive isfix fixl notations =
 	   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
+		 Typing.e_solve_evars env evdref app
+	     with e  when CErrors.noncritical e -> t
 	   in
-	     (id,None,fixprot) :: env'
-	 else (id,None,t) :: env')
+	     LocalAssum (id,fixprot) :: env'
+	 else LocalAssum (id,t) :: env')
       [] fixnames fixtypes
   in
   let env_rec = push_named_context rec_sign env in
@@ -1098,11 +1130,11 @@ let interp_recursive isfix fixl notations =
       () in
 
   (* Instantiate evars and check all are resolved *)
-  let evd = consider_remaining_unif_problems env_rec !evdref in
+  let evd = solve_unif_constraints_with_heuristics env_rec !evdref 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 fixctxnames = List.map (fun (_,ctx) -> List.map get_name ctx) fixctxs in
 
   (* Build the fix declaration block *)
   (env,rec_sign,all_universes,evd), (fixnames,fixdefs,fixtypes), List.combine3 fixctxnames fiximps fixannots
@@ -1220,6 +1252,11 @@ let out_def = function
   | Some def -> def
   | None -> error "Program Fixpoint needs defined bodies."
 
+let collect_evars_of_term evd c ty =
+  let evars = Evar.Set.union (Evd.evars_of_term c) (Evd.evars_of_term ty) in
+  Evar.Set.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evd ev))
+  evars (Evd.from_ctx (Evd.evar_universe_context evd))
+
 let do_program_recursive local p fixkind fixl ntns =
   let isfix = fixkind != Obligations.IsCoFixpoint in
   let (env, rec_sign, pl, evd), fix, info = 
@@ -1237,8 +1274,9 @@ let do_program_recursive local p fixkind fixl ntns =
     and typ =
       nf_evar evd (Termops.it_mkNamedProd_or_LetIn typ rec_sign)
     in
+    let evm = collect_evars_of_term evd def typ in
     let evars, _, def, typ = 
-      Obligations.eterm_obligations env id evd
+      Obligations.eterm_obligations env id evm
 	(List.length rec_sign) def typ
     in (id, def, typ, imps, evars)
   in
@@ -1253,30 +1291,34 @@ let do_program_recursive local p fixkind fixl ntns =
 	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
+        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
+  Obligations.add_mutual_definitions defs ~kind ?pl 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)] ->
+    | [(n, CWfRec r)], [((((_,id),pl),_,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
+	in build_wellfounded (id, pl, n, bl, typ, out_def def) poly r recarg ntn
 	     
-    | [(n, CMeasureRec (m, r))], [((((_,id),_),_,bl,typ,def),ntn)] ->
-	build_wellfounded (id, n, bl, typ, out_def def)
+    | [(n, CMeasureRec (m, r))], [((((_,id),pl),_,bl,typ,def),ntn)] ->
+	build_wellfounded (id, pl, n, bl, typ, out_def def) poly
 	  (Option.default (CRef (lt_ref,None)) r) m ntn
 	  
     | _, _ when List.for_all (fun (n, ro) -> ro == CStructRec) g ->
@@ -1288,6 +1330,11 @@ let do_program_fixpoint local poly l =
 	errorlabstrm "do_program_fixpoint"
 	  (str "Well-founded fixpoints not allowed in mutually recursive blocks")
 
+let check_safe () =
+  let open Declarations in
+  let flags = Environ.typing_flags (Global.env ()) in
+  flags.check_universes && flags.check_guarded
+
 let do_fixpoint local poly l =
   if Flags.is_program_mode () then do_program_fixpoint local poly l
   else
@@ -1295,7 +1342,8 @@ let do_fixpoint local poly l =
     let (_, _, _, info as fix) = interp_fixpoint fixl ntns in
     let possible_indexes =
       List.map compute_possible_guardness_evidences info in
-    declare_fixpoint local poly fix possible_indexes ntns
+    declare_fixpoint local poly fix possible_indexes ntns;
+    if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else ()
 
 let do_cofixpoint local poly l =
   let fixl,ntns = extract_cofixpoint_components l in
@@ -1303,4 +1351,5 @@ let do_cofixpoint local poly l =
       do_program_recursive local poly Obligations.IsCoFixpoint fixl ntns
     else
       let cofix = interp_cofixpoint fixl ntns in
-	declare_cofixpoint local poly cofix ntns
+      declare_cofixpoint local poly cofix ntns;
+      if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else ()
diff --git a/toplevel/command.mli b/toplevel/command.mli
index b97cb487..616afb91 100644
--- a/toplevel/command.mli
+++ b/toplevel/command.mli
@@ -22,7 +22,7 @@ open Pfedit
 
 val do_universe : polymorphic -> Id.t Loc.located list -> unit
 val do_constraint : polymorphic ->
-  (Id.t Loc.located * Univ.constraint_type * Id.t Loc.located) list -> unit
+  (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> unit
 
 (** {6 Hooks for Pcoq} *)
 
@@ -161,9 +161,11 @@ val declare_cofixpoint : locality -> polymorphic ->
 (** Entry points for the vernacular commands Fixpoint and CoFixpoint *)
 
 val do_fixpoint :
+  (* When [false], assume guarded. *)
   locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit
 
 val do_cofixpoint :
+  (* When [false], assume guarded. *)
   locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit
 
 (** Utils *)
diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml
index 91cec4bb..acbf909c 100644
--- a/toplevel/coqinit.ml
+++ b/toplevel/coqinit.ml
@@ -36,7 +36,7 @@ let load_rcfile() =
         else raise (Sys_error ("Cannot read rcfile: "^ !rcfile))
       else
 	try
-	  let warn x = msg_warning (str x) in
+	  let warn x = Feedback.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;
@@ -51,21 +51,20 @@ let load_rcfile() =
 			 " found. Skipping rcfile loading."))
 	*)
     with reraise ->
-      let reraise = Errors.push reraise in
-      let () = msg_info (str"Load of rcfile failed.") in
+      let reraise = CErrors.push reraise in
+      let () = Feedback.msg_info (str"Load of rcfile failed.") in
       iraise reraise
   else
-    Flags.if_verbose msg_info (str"Skipping rcfile loading.")
+    Flags.if_verbose Feedback.msg_info (str"Skipping rcfile loading.")
 
 (* Recursively puts dir in the LoadPath if -nois was not passed *)
 let add_stdlib_path ~unix_path ~coq_root ~with_ml =
-  Mltop.add_rec_path ~unix_path ~coq_root ~implicit:(!Flags.load_init);
-  if with_ml then
-    Mltop.add_rec_ml_dir unix_path
+  let add_ml = if with_ml then Mltop.AddRecML else Mltop.AddNoML in
+  Mltop.add_rec_path add_ml ~unix_path ~coq_root ~implicit:(!Flags.load_init)
 
 let add_userlib_path ~unix_path =
-  Mltop.add_rec_path ~unix_path ~coq_root:Nameops.default_root_prefix ~implicit:false;
-  Mltop.add_rec_ml_dir unix_path
+  Mltop.add_rec_path Mltop.AddRecML ~unix_path
+    ~coq_root:Nameops.default_root_prefix ~implicit:false
 
 (* Options -I, -I-as, and -R of the command line *)
 let includes = ref []
@@ -78,7 +77,7 @@ let push_ml_include s = ml_includes := s :: !ml_includes
 let init_load_path () =
   let coqlib = Envars.coqlib () in
   let user_contrib = coqlib/"user-contrib" in
-  let xdg_dirs = Envars.xdg_dirs ~warn:(fun x -> msg_warning (str x)) in
+  let xdg_dirs = Envars.xdg_dirs ~warn:(fun x -> Feedback.msg_warning (str x)) in
   let coqpath = Envars.coqpath in
   let coq_root = Names.DirPath.make [Nameops.coq_root] in
     (* NOTE: These directories are searched from last to first *)
@@ -90,7 +89,8 @@ let init_load_path () =
       Mltop.add_ml_dir (coqlib/"stm");
       Mltop.add_ml_dir (coqlib/"ide")
     end;
-    Mltop.add_ml_dir (coqlib/"toploop");
+    if System.exists_dir (coqlib/"toploop") then
+      Mltop.add_ml_dir (coqlib/"toploop");
     (* then standard library *)
     add_stdlib_path ~unix_path:(coqlib/"theories") ~coq_root ~with_ml:false;
     (* then plugins *)
@@ -108,7 +108,7 @@ let init_load_path () =
     (* additional loadpath, given with options -Q and -R *)
     List.iter
       (fun (unix_path, coq_root, implicit) ->
-        Mltop.add_rec_path ~unix_path ~coq_root ~implicit)
+        Mltop.add_rec_path Mltop.AddNoML ~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)
@@ -125,16 +125,18 @@ let init_ocaml_path () =
     Mltop.add_ml_dir (Envars.coqlib ());
     List.iter add_subdir
       [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ];
-	[ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ];
+	[ "engine" ]; [ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ];
 	[ "tactics" ]; [ "toplevel" ]; [ "printing" ]; [ "intf" ];
-        [ "grammar" ]; [ "ide" ] ]
+        [ "grammar" ]; [ "ide" ]; [ "ltac" ]; ]
 
 let get_compat_version = function
-  | "8.5" -> Flags.Current
+  | "8.6" -> Flags.Current
+  | "8.5" -> Flags.V8_5
   | "8.4" -> Flags.V8_4
   | "8.3" -> Flags.V8_3
   | "8.2" -> Flags.V8_2
   | ("8.1" | "8.0") as s ->
-    msg_warning (str "Compatibility with version " ++ str s ++ str " not supported.");
-    Flags.V8_2
-  | s -> Errors.errorlabstrm "get_compat_version" (str "Unknown compatibility version \"" ++ str s ++ str "\".")
+    CErrors.errorlabstrm "get_compat_version"
+      (str "Compatibility with version " ++ str s ++ str " not supported.")
+  | s -> CErrors.errorlabstrm "get_compat_version"
+      (str "Unknown compatibility version \"" ++ str s ++ str "\".")
diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml
index 063ed896..e9771cfa 100644
--- a/toplevel/coqloop.ml
+++ b/toplevel/coqloop.ml
@@ -7,12 +7,14 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Flags
 open Vernac
 open Pcoq
 
+let top_stderr x = msg_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft x
+
 (* A buffer for the character read from a channel. We store the command
  * entered to be able to report errors without pretty-printing. *)
 
@@ -21,7 +23,7 @@ type input_buffer = {
   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 beginning of lines *)
-  mutable tokens : Gram.parsable; (* stream of tokens *)
+  mutable tokens : Gram.coq_parsable; (* stream of tokens *)
   mutable start : int } (* stream count of the first char of the buffer *)
 
 (* Double the size of the buffer. *)
@@ -32,7 +34,7 @@ let resize_buffer ibuf =
   ibuf.str <- nstr
 
 (* 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. *)
+   in the buffer (useful when there are several commands on the same line). *)
 
 let resynch_buffer ibuf =
   match ibuf.bols with
@@ -59,7 +61,7 @@ let prompt_char ic ibuf count =
     | ll::_ -> Int.equal ibuf.len ll
     | [] -> Int.equal ibuf.len 0
   in
-  if bol && not !print_emacs then msgerr (str (ibuf.prompt()));
+  if bol && not !print_emacs then top_stderr (str (ibuf.prompt()));
   try
     let c = input_char ic in
     if c == '\n' then ibuf.bols <- (ibuf.len+1) :: ibuf.bols;
@@ -144,44 +146,23 @@ let print_highlight_location ib loc =
                       str sn ++ str dn) in
 	  (l1 ++ li ++ ln)
   in
-  let loc = Loc.make_loc (bp,ep) in
-  (str"Toplevel input, characters " ++ Cerrors.print_loc loc ++ str":" ++ fnl () ++
-     highlight_lines ++ fnl ())
+  let loc  = Loc.make_loc (bp,ep) in
+  (Pp.pr_loc loc ++ highlight_lines ++ fnl ())
 
 (* Functions to report located errors in a file. *)
 
-let print_location_in_file {outer=s;inner=fname} loc =
-  let errstrm = str"Error while reading " ++ str s in
+let print_location_in_file loc =
+  let fname = loc.Loc.fname in
+  let errstrm = str"Error while reading " ++ str fname in
   if Loc.is_ghost loc then
     hov 1 (errstrm ++ spc() ++ str" (unknown location):") ++ fnl ()
   else
-    let errstrm =
-      if String.equal s fname then mt() else errstrm ++ str":" ++ fnl()
+    let errstrm = mt ()
+      (* if String.equal outer_fname fname then mt() else errstrm ++ str":" ++ fnl() *)
     in
-    let (bp,ep) = Loc.unloc loc in
-    let line_of_pos lin bol cnt =
-      try
-        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;
-        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 "\"" ++ str fname ++ str "\"" ++
-           str", line " ++ int line ++ str", characters " ++
-           Cerrors.print_loc (Loc.make_loc (bp-bol,ep-bol))) ++ str":" ++
-        fnl ()
-    with e when Errors.noncritical e ->
-       hov 1 (errstrm ++ spc() ++ str"(invalid location):") ++ fnl ()
+    let open Loc in
+    hov 0 (* No line break so as to follow emacs error message format *)
+	(errstrm ++ Pp.pr_loc loc)
 
 let valid_buffer_loc ib loc =
   not (Loc.is_ghost loc) &&
@@ -262,14 +243,15 @@ let locate_exn = function
 
 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 ->
+  let fname = loc.Loc.fname in
+  let locmsg =
+    if Loc.is_ghost loc || String.equal fname "" then
       if locate_exn e && valid_buffer_loc top_buffer loc then
-        print_highlight_location top_buffer loc
+	print_highlight_location top_buffer loc
       else mt ()
+    else print_location_in_file loc
   in
-  locmsg ++ Errors.iprint (e, info)
+  locmsg ++ CErrors.iprint (e, info)
 
 (* Read the input stream until a dot is encountered *)
 let parse_to_dot =
@@ -288,14 +270,16 @@ let rec discard_to_dot () =
   try
     Gram.entry_parse parse_to_dot top_buffer.tokens
   with
-    | Compat.Token.Error _ | Lexer.Error.E _ -> discard_to_dot ()
+    | Compat.Token.Error _ | CLexer.Error.E _ -> discard_to_dot ()
     | End_of_input -> raise End_of_input
-    | e when Errors.noncritical e -> ()
+    | e when CErrors.noncritical e -> ()
 
-let read_sentence () =
-  try Vernac.parse_sentence (top_buffer.tokens, None)
+let read_sentence input =
+  try
+    let (loc, _ as r) = Vernac.parse_sentence input in
+    CWarnings.set_current_loc loc; r
   with reraise ->
-    let reraise = Errors.push reraise in
+    let reraise = CErrors.push reraise in
     discard_to_dot ();
     iraise reraise
 
@@ -310,23 +294,23 @@ let read_sentence () =
 *)
 
 let do_vernac () =
-  msgerrnl (mt ());
-  if !print_emacs then msgerr (str (top_buffer.prompt()));
+  top_stderr (fnl());
+  if !print_emacs then top_stderr (str (top_buffer.prompt()));
   resynch_buffer top_buffer;
   try
-    Vernac.eval_expr (read_sentence ())
+    let input = (top_buffer.tokens, None) in
+    Vernac.process_expr top_buffer.tokens (read_sentence input)
   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 ())
+    | End_of_input | CErrors.Quit ->
+        top_stderr (fnl ()); raise CErrors.Quit
+    | CErrors.Drop ->  (* Last chance *)
+        if Mltop.is_ocaml_top() then raise CErrors.Drop
+        else Feedback.msg_error (str"There is no ML toplevel.")
     | any ->
-        let any = Errors.push any in
-        Format.set_formatter_out_channel stdout;
+        let any = CErrors.push any in
         let msg = print_toplevel_error any ++ fnl () in
         pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft msg;
-        pp_flush ()
+        Format.pp_print_flush !Pp_control.std_ft ()
 
 (** Main coq loop : read vernacular expressions until Drop is entered.
     Ctrl-C is handled internally as Sys.Break instead of aborting Coq.
@@ -343,18 +327,28 @@ let feed_emacs = function
   | _  -> ()
 *)
 
+(* Flush in a compatible order with 8.5 *)
+(* This mimics the semantics of the old Pp.flush_all *)
+let loop_flush_all () =
+  Pervasives.flush stderr;
+  Pervasives.flush stdout;
+  Format.pp_print_flush !Pp_control.std_ft ();
+  Format.pp_print_flush !Pp_control.err_ft ()
+
 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(); flush_all() done
+    while true do do_vernac(); loop_flush_all () done
   with
-    | Errors.Drop -> ()
-    | Errors.Quit -> exit 0
+    | CErrors.Drop -> ()
+    | CErrors.Quit -> exit 0
     | any ->
-      msgerrnl (str"Anomaly: main loop exited with exception: " ++
+      Feedback.msg_error (str"Anomaly: main loop exited with exception: " ++
                 str (Printexc.to_string any) ++
-                fnl() ++ str"Please report.");
+                fnl() ++
+                str"Please report" ++
+                strbrk" at " ++ str Coq_config.wwwbugtracker ++ str ".");
       loop ()
diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli
index 00554da3..e40353e0 100644
--- a/toplevel/coqloop.mli
+++ b/toplevel/coqloop.mli
@@ -18,7 +18,7 @@ type input_buffer = {
   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 tokens : Pcoq.Gram.parsable; (** stream of tokens *)
+  mutable tokens : Pcoq.Gram.coq_parsable; (** stream of tokens *)
   mutable start : int } (** stream count of the first char of the buffer *)
 
 (** The input buffer of stdin. *)
diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml
index afd4ef40..d9f8ed88 100644
--- a/toplevel/coqtop.ml
+++ b/toplevel/coqtop.ml
@@ -7,9 +7,8 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
-open System
 open Flags
 open Names
 open Libnames
@@ -27,15 +26,15 @@ let get_version_date () =
     let rev = input_line ch in
     let () = close_in ch in
     (ver,rev)
-  with e when Errors.noncritical e ->
+  with e when CErrors.noncritical e ->
     (Coq_config.version,Coq_config.date)
 
 let print_header () =
   let (ver,rev) = get_version_date () in
-  ppnl (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")");
-  pp_flush ()
+  Feedback.msg_notice (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")");
+  flush_all ()
 
-let warning s = msg_warning (strbrk s)
+let warning s = with_option Flags.warn Feedback.msg_warning (strbrk s)
 
 let toploop = ref None
 
@@ -55,14 +54,14 @@ let init_color () =
     Terminal.has_style Unix.stderr &&
     (* emacs compilation buffer does not support colors by default,
        its TERM variable is set to "dumb". *)
-    Unix.getenv "TERM" <> "dumb"
+    try Sys.getenv "TERM" <> "dumb" with Not_found -> false
   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 ()
+      Feedback.init_color_output ()
     | Some "" ->
       (** No color output *)
       ()
@@ -70,7 +69,7 @@ let init_color () =
       (** Overwrite all colors *)
       Ppstyle.clear_styles ();
       Ppstyle.parse_config s;
-      Ppstyle.init_color_output ()
+      Feedback.init_color_output ()
   end
 
 let toploop_init = ref begin fun x ->
@@ -96,8 +95,8 @@ let memory_stat = ref false
 let print_memory_stat () =
   begin (* -m|--memory from the command-line *)
     if !memory_stat then
-    ppnl
-      (str "total heap size = " ++ int (CObj.heap_size_kb ()) ++ str " kbytes");
+    Feedback.msg_notice
+      (str "total heap size = " ++ int (CObj.heap_size_kb ()) ++ str " kbytes" ++ fnl ());
   end;
   begin
     (* operf-macro interface:
@@ -114,23 +113,14 @@ let _ = at_exit print_memory_stat
 
 let impredicative_set = ref Declarations.PredicativeSet
 let set_impredicative_set c = impredicative_set := Declarations.ImpredicativeSet
-let type_in_type = ref Declarations.StratifiedType
-let set_type_in_type () = type_in_type := Declarations.TypeInType
+let set_type_in_type () =
+  let typing_flags = Environ.typing_flags (Global.env ()) in
+  Global.set_typing_flags { typing_flags with Declarations.check_universes = false }
 let engage () =
-  Global.set_engagement (!impredicative_set,!type_in_type)
+  Global.set_engagement !impredicative_set
 
 let set_batch_mode () = batch_mode := true
 
-let user_warning = ref false
-(** User explicitly set warning *)
-
-let set_warning p =
-  let () = user_warning := true in
-  match p with
-  | "all" -> make_warn true
-  | "none" -> make_warn false
-  | _ -> prerr_endline ("Error: all/none expected after option w"); exit 1
-
 let toplevel_default_name = DirPath.make [Id.of_string "Top"]
 let toplevel_name = ref (Some toplevel_default_name)
 let set_toplevel_name dir =
@@ -140,18 +130,27 @@ let unset_toplevel_name () = toplevel_name := None
 
 let remove_top_ml () = Mltop.remove ()
 
+let warn_deprecated_inputstate =
+  CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated"
+         (fun () -> strbrk "The inputstate option is deprecated and discouraged.")
+
 let inputstate = ref ""
 let set_inputstate s =
-  let () = msg_warning (str "The inputstate option is deprecated and discouraged.") in
+  warn_deprecated_inputstate ();
   inputstate:=s
 let inputstate () =
   if not (String.is_empty !inputstate) then
     let fname = Loadpath.locate_file (CUnix.make_suffix !inputstate ".coq") in
     intern_state fname
 
+let warn_deprecated_outputstate =
+  CWarnings.create ~name:"deprecated-outputstate" ~category:"deprecated"
+         (fun () ->
+          strbrk "The outputstate option is deprecated and discouraged.")
+
 let outputstate = ref ""
 let set_outputstate s =
-  let () = msg_warning (str "The outputstate option is deprecated and discouraged.") in
+  warn_deprecated_outputstate ();
   outputstate:=s
 let outputstate () =
   if not (String.is_empty !outputstate) then
@@ -169,7 +168,7 @@ let load_vernacular () =
   List.iter
     (fun (s,b) ->
       let s = Loadpath.locate_file s in
-      if Flags.do_beautify () then
+      if !Flags.beautify then
 	with_option beautify_file (Vernac.load_vernac b) s
       else
 	Vernac.load_vernac b s)
@@ -199,6 +198,7 @@ let require () =
 let add_compat_require v =
   match v with
   | Flags.V8_4 -> add_require "Coq.Compat.Coq84"
+  | Flags.V8_5 -> add_require "Coq.Compat.Coq85"
   | _ -> ()
 
 let compile_list = ref ([] : (bool * string) list)
@@ -219,33 +219,44 @@ let add_compile verbose s =
   compile_list := (verbose,s) :: !compile_list
 
 let compile_file (v,f) =
-  if Flags.do_beautify () then
+  if !Flags.beautify then
     with_option beautify_file (Vernac.compile v) f
   else
     Vernac.compile v f
 
 let compile_files () =
-  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)
+  if !compile_list == [] then ()
+  else
+    let init_state = States.freeze ~marshallable:`No in
+    Feedback.(add_feeder debug_feeder);
+    List.iter (fun vf ->
+        States.unfreeze init_state;
+        compile_file vf)
+      (List.rev !compile_list)
 
 (** Options for proof general *)
 
 let set_emacs () =
+  if not (Option.is_empty !toploop) then
+    error "Flag -emacs is incompatible with a custom toplevel loop";
   Flags.print_emacs := true;
-  Pp.make_pp_emacs ();
+  Feedback.(set_logger emacs_logger);
   Vernacentries.qed_display_script := false;
   color := `OFF
 
+(** Options for CoqIDE *)
+
+let set_ideslave () =
+  if !Flags.print_emacs then error "Flags -ideslave and -emacs are incompatible";
+  toploop := Some "coqidetop";
+  Flags.ide_slave := true
+
+(** Options for slaves *)
+
+let set_toploop name =
+  if !Flags.print_emacs then error "Flags -toploop and -emacs are incompatible";
+  toploop := Some name
+
 (** GC tweaking *)
 
 (** Coq is a heavy user of persistent data structures and symbolic ASTs, so the
@@ -257,25 +268,26 @@ let set_emacs () =
 *)
 
 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
+  try
+    (* OCAMLRUNPARAM environment variable is set.
+     * In that case, we let ocamlrun to use the values provided by the user.
+     *)
+    ignore (Sys.getenv "OCAMLRUNPARAM")
+
+  with Not_found ->
+    (* OCAMLRUNPARAM environment variable is not set.
+     * In this case, we put in place our preferred configuration.
+     *)
+    Gc.set { (Gc.get ()) with
+             Gc.minor_heap_size = 33554432; (** 4M *)
+             Gc.space_overhead = 120}
 
 (*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 () =
-  Envars.set_coqlib Errors.error;
+  Envars.set_coqlib CErrors.error;
   init_load_path ();
   if !batch_mode then Usage.print_usage_coqc ()
   else begin
@@ -316,9 +328,6 @@ let error_missing_arg s =
 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 print_where = ref false
 let print_config = ref false
 let print_tags = ref false
@@ -353,15 +362,25 @@ let get_int opt n =
   with Failure _ ->
     prerr_endline ("Error: integer expected after option "^opt); exit 1
 
+let get_float opt n =
+  try float_of_string n
+  with Failure _ ->
+    prerr_endline ("Error: float expected after option "^opt); exit 1
+
 let get_host_port opt s =
   match CString.split ':' s with
   | [host; portr; portw] ->
        Some (Spawned.Socket(host, int_of_string portr, int_of_string portw))
   | ["stdfds"] -> Some Spawned.AnonPipe
   | _ ->
-     prerr_endline ("Error: host:port or stdfds expected after option "^opt);
+     prerr_endline ("Error: host:portr:portw or stdfds expected after option "^opt);
      exit 1
 
+let get_error_resilience opt = function
+  | "on" | "all" | "yes" -> `All
+  | "off" | "no" -> `None
+  | s -> `Only (String.split ',' s)
+
 let get_task_list s = List.map int_of_string (Str.split (Str.regexp ",") s)
 
 let vio_tasks = ref []
@@ -442,10 +461,6 @@ let parse_args arglist =
       end
     |"-R" ->
       begin match rem with
-      | d :: "-as" :: [] -> error_missing_arg opt
-      | d :: "-as" :: p :: rem ->
-        warning "option -R * -as * deprecated, remove the -as";
-        set_include d p true; args := rem
       | d :: p :: rem -> set_include d p true; args := rem
       | _ -> error_missing_arg opt
       end
@@ -479,13 +494,19 @@ let parse_args arglist =
         Flags.async_proofs_worker_priority := get_priority opt (next ())
     |"-async-proofs-private-flags" ->
         Flags.async_proofs_private_flags := Some (next ());
+    |"-async-proofs-tactic-error-resilience" ->
+        Flags.async_proofs_tac_error_resilience := get_error_resilience opt (next ())
+    |"-async-proofs-command-error-resilience" ->
+        Flags.async_proofs_cmd_error_resilience := get_bool opt (next ())
+    |"-async-proofs-delegation-threshold" ->
+        Flags.async_proofs_delegation_threshold:= get_float opt (next ())
     |"-worker-id" -> set_worker_id opt (next ())
     |"-compat" -> let v = get_compat_version (next ()) in Flags.compat_version := v; add_compat_require v
     |"-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 ())
+    |"-exclude-dir" -> System.exclude_directory (next ())
     |"-init-file" -> set_rcfile (next ())
     |"-inputstate"|"-is" -> set_inputstate (next ())
     |"-load-ml-object" -> Mltop.dir_ml_load (next ())
@@ -495,14 +516,16 @@ let parse_args arglist =
     |"-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
+    |"-profile-ltac-cutoff" -> Flags.profile_ltac := true; Flags.profile_ltac_cutoff := get_float opt (next ())
     |"-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 ())
-    |"-w" -> set_warning (next ())
+    |"-toploop" -> set_toploop (next ())
+    |"-w" | "-W" -> CWarnings.set_flags (CWarnings.normalize_flags_string (next ()))
+    |"-o" -> Flags.compilation_output_name := Some (next())
 
     (* Options with zero arg *)
     |"-async-queries-always-delegate"
@@ -513,7 +536,7 @@ let parse_args arglist =
         Flags.async_proofs_never_reopen_branch := true;
     |"-batch" -> set_batch_mode ()
     |"-test-mode" -> test_mode := true
-    |"-beautify" -> make_beautify true
+    |"-beautify" -> beautify := true
     |"-boot" -> boot := true; no_load_rc ()
     |"-bt" -> Backtrace.record_backtrace true
     |"-color" -> set_color (next ())
@@ -522,13 +545,12 @@ let parse_args arglist =
     |"-emacs" -> set_emacs ()
     |"-filteropts" -> filter_opts := true
     |"-h"|"-H"|"-?"|"-help"|"--help" -> usage ()
-    |"-ideslave" -> toploop := Some "coqidetop"; Flags.ide_slave := true
+    |"-ideslave" -> set_ideslave ()
     |"-impredicative-set" -> set_impredicative_set ()
     |"-indices-matter" -> Indtypes.enforce_indices_matter ()
-    |"-just-parsing" -> Vernac.just_parsing := true
+    |"-just-parsing" -> warning "-just-parsing option has been removed in 8.6"
     |"-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
     |"-native-compiler" ->
       if Coq_config.no_native_compiler then
@@ -536,6 +558,7 @@ let parse_args arglist =
       else native_compiler := true
     |"-notop" -> unset_toplevel_name ()
     |"-output-context" -> output_context := true
+    |"-profile-ltac" -> Flags.profile_ltac := true
     |"-q" -> no_load_rc ()
     |"-quiet"|"-silent" -> Flags.make_silent true; Flags.make_warn false
     |"-quick" -> Flags.compilation_mode := BuildVio
@@ -544,7 +567,7 @@ let parse_args arglist =
     |"-type-in-type" -> set_type_in_type ()
     |"-unicode" -> add_require "Utf8_core"
     |"-v"|"--version" -> Usage.version (exitcode ())
-    |"-verbose-compat-notations" -> verb_compat_ntn := true
+    |"--print-version" -> Usage.machine_readable_version (exitcode ())
     |"-where" -> print_where := true
     |"-xml" -> Flags.xml_export := true
 
@@ -573,10 +596,10 @@ let parse_args arglist =
   with
     | 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)
+      else fatal_error (CErrors.print e) false
+    | any -> fatal_error (CErrors.print any) (CErrors.is_anomaly any)
 
-let init arglist =
+let init_toplevel arglist =
   init_gc ();
   Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *)
   Lib.init();
@@ -588,7 +611,7 @@ let init arglist =
       (* 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;
+      Envars.set_coqlib CErrors.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 ()));
@@ -605,9 +628,6 @@ let init arglist =
       inputstate ();
       Mltop.init_known_plugins ();
       engage ();
-      (* 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 || List.is_empty !compile_list)
          && Global.env_is_initial ()
       then Option.iter Declaremods.start_library !toplevel_name;
@@ -623,30 +643,27 @@ let init arglist =
       check_vio_tasks ();
       outputstate ()
     with any ->
-      let any = Errors.push any in
+      let any = CErrors.push any in
       flush_all();
       let msg =
         if !batch_mode then mt ()
         else str "Error during initialization:" ++ fnl ()
       in
-      let is_anomaly e = Errors.is_anomaly e || not (Errors.handled e) in
+      let is_anomaly e = CErrors.is_anomaly e || not (CErrors.handled e) in
       fatal_error (msg ++ Coqloop.print_toplevel_error any) (is_anomaly (fst any))
   end;
   if !batch_mode then begin
     flush_all();
     if !output_context then
-      Pp.ppnl (with_option raw_print Prettyp.print_full_pure_context ());
+      Feedback.msg_notice (with_option raw_print Prettyp.print_full_pure_context () ++ fnl ());
     Profile.print_profile ();
     exit 0
   end
 
-let init_toplevel = init
-
 let start () =
   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 ...  *)
-  if not !user_warning then make_warn true;
   !toploop_run ();
   exit 1
 
diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml
index 61573091..e24d5e74 100644
--- a/toplevel/discharge.ml
+++ b/toplevel/discharge.ml
@@ -7,22 +7,23 @@
 (************************************************************************)
 
 open Names
-open Errors
+open CErrors
 open Util
-open Context
 open Term
 open Vars
-open Entries
 open Declarations
 open Cooking
+open Entries
+open Context.Rel.Declaration
 
 (********************************)
 (* Discharging mutual inductive *)
 
-let detype_param = function
-  | (Name id,None,p) -> id, LocalAssum p
-  | (Name id,Some p,_) -> id, LocalDef p
-  | (Anonymous,_,_) -> anomaly (Pp.str "Unnamed inductive local variable")
+let detype_param =
+  function
+  | LocalAssum (Name id, p) -> id, LocalAssumEntry p
+  | LocalDef (Name id, p,_) -> id, LocalDefEntry p
+  | _ -> anomaly (Pp.str "Unnamed inductive local variable")
 
 (* Replace
 
@@ -37,8 +38,8 @@ let detype_param = function
 
 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 nhyp = Context.Named.length hyps in
+  let args = Context.Named.to_instance (List.rev hyps) 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' =
@@ -53,7 +54,7 @@ let abstract_inductive hyps nparams inds =
 (* 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,_) = decompose_prod_n_assum nparams' arity in
-		  List.map detype_param params
+                List.map detype_param params
   in
   let ind'' =
   List.map
@@ -100,7 +101,7 @@ let process_inductive (sechyps,abs_ctx) modlist mib =
 	   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 sechyps' = Context.Named.map (expmod_constr modlist) sechyps in
   let (params',inds') = abstract_inductive sechyps' nparams inds in
   let abs_ctx = Univ.instantiate_univ_context abs_ctx in
   let univs = Univ.UContext.union abs_ctx univs in
@@ -115,5 +116,5 @@ let process_inductive (sechyps,abs_ctx) modlist mib =
     mind_entry_inds = inds';
     mind_entry_polymorphic = mib.mind_polymorphic;
     mind_entry_private = mib.mind_private;
-    mind_entry_universes = univs
+    mind_entry_universes = univs;
   }
diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli
index 59140157..18d1b677 100644
--- a/toplevel/discharge.mli
+++ b/toplevel/discharge.mli
@@ -6,10 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Context
 open Declarations
 open Entries
 open Opaqueproof
 
 val process_inductive :
-  named_context Univ.in_universe_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry
+  Context.Named.t Univ.in_universe_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry
diff --git a/toplevel/cerrors.ml b/toplevel/explainErr.ml
index 600683d3..17897460 100644
--- a/toplevel/cerrors.ml
+++ b/toplevel/explainErr.ml
@@ -7,19 +7,12 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Indtypes
 open Type_errors
 open Pretype_errors
 open Indrec
 
-let print_loc loc =
-  if Loc.is_ghost loc then
-    (str"<unknown>")
-  else
-    let loc = Loc.unloc loc in
-    (int (fst loc) ++ str"-" ++ int (snd loc))
-
 let guill s = str "\"" ++ str s ++ str "\""
 
 (** Invariant : exceptions embedded in EvaluatedError satisfy
@@ -35,7 +28,7 @@ let explain_exn_default = function
   (* Basic interaction exceptions *)
   | Stream.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".")
   | Compat.Token.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".")
-  | Lexer.Error.E err -> hov 0 (str (Lexer.Error.to_string err))
+  | CLexer.Error.E err -> hov 0 (str (CLexer.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.")
@@ -43,11 +36,11 @@ let explain_exn_default = function
   | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.")
   (* Exceptions with pre-evaluated error messages *)
   | EvaluatedError (msg,None) -> msg
-  | EvaluatedError (msg,Some reraise) -> msg ++ Errors.print reraise
+  | EvaluatedError (msg,Some reraise) -> msg ++ CErrors.print reraise
   (* Otherwise, not handled here *)
-  | _ -> raise Errors.Unhandled
+  | _ -> raise CErrors.Unhandled
 
-let _ = Errors.register_handler explain_exn_default
+let _ = CErrors.register_handler explain_exn_default
 
 
 (** Pre-explain a vernac interpretation error *)
@@ -110,29 +103,27 @@ let rec strip_wrapping_exceptions = function
     strip_wrapping_exceptions e
   | exc -> exc
 
+let additional_error_info = ref []
+
+let register_additional_error_info f =
+  additional_error_info := f :: !additional_error_info
+
 let process_vernac_interp_error ?(allow_uncaught=true) ?(with_header=true) (exc, info) =
   let exc = strip_wrapping_exceptions exc in
   let e = process_vernac_interp_error with_header (exc, info) in
   let () =
-    if not allow_uncaught && not (Errors.handled (fst e)) then
+    if not allow_uncaught && not (CErrors.handled (fst e)) then
       let (e, info) = e in
       let msg = str "Uncaught exception " ++ str (Printexc.to_string e) in
-      let err = Errors.make_anomaly msg in
+      let err = CErrors.make_anomaly msg in
       Util.iraise (err, 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
+  let e' =
+    try Some (CList.find_map (fun f -> f e) !additional_error_info)
+    with _ -> None
+  in
+  match e' 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 (fst (process_vernac_interp_error (e, Exninfo.null))))
-
-let _ = Tactic_debug.explain_logic_error_no_anomaly :=
-  (fun e -> Errors.print_no_report (fst (process_vernac_interp_error (e, Exninfo.null))))
+  | Some (None, loc) -> (fst e, Loc.add_loc (snd e) loc)
+  | Some (Some msg, loc) ->
+    (EvaluatedError (msg, Some (fst e)), Loc.add_loc (snd e) loc)
diff --git a/toplevel/cerrors.mli b/toplevel/explainErr.mli
index 68c46010..a67c887a 100644
--- a/toplevel/cerrors.mli
+++ b/toplevel/explainErr.mli
@@ -6,9 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(** Error report. *)
-
-val print_loc : Loc.t -> Pp.std_ppcmds
+(** Toplevel Exception *)
+exception EvaluatedError of Pp.std_ppcmds * exn option
 
 (** Pre-explain a vernac interpretation error *)
 
@@ -19,3 +18,4 @@ val process_vernac_interp_error : ?allow_uncaught:bool -> ?with_header:bool -> U
 
 val explain_exn_default : exn -> Pp.std_ppcmds
 
+val register_additional_error_info : (Util.iexn -> (Pp.std_ppcmds option * Loc.t) option) -> unit
diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml
index 7ddfd46c..f98505c3 100644
--- a/toplevel/himsg.ml
+++ b/toplevel/himsg.ml
@@ -23,22 +23,26 @@ open Cases
 open Logic
 open Printer
 open Evd
+open Context.Rel.Declaration
 
 (* 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' ->
+  let contract_context decl env =
+    match decl with
+      | LocalDef (_,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
+          let t' = Vars.substl !l (get_type decl) in
+          let c' = Option.map (Vars.substl !l) (get_value decl) in
+          let na' = named_hd env t' (get_name decl) in
           l := (mkRel 1) :: List.map (Vars.lift 1) !l;
-          push_rel (na',c',t') env in
+          match c' with
+          | None -> push_rel (LocalAssum (na',t')) env
+          | Some c' -> push_rel (LocalDef (na',c',t')) env
+  in
   let env = process_rel_context contract_context env in
   (env, List.map (Vars.substl !l) lc)
 
@@ -65,12 +69,21 @@ let rec contract3' env a b c = function
       let (env',t1,t2) = contract2 env' t1 t2 in
       contract3 env a b c, ConversionFailed (env',t1,t2)
   | NotSameArgSize | NotSameHead | NoCanonicalStructure
-  | MetaOccurInBody _ | InstanceNotSameType _
+  | MetaOccurInBody _ | InstanceNotSameType _ | ProblemBeyondCapabilities
   | UnifUnivInconsistency _ as x -> contract3 env a b c, x
-  | CannotSolveConstraint ((pb,env,t,u),x) ->
-      let env,t,u = contract2 env t u in
+  | 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)
+      y,CannotSolveConstraint ((pb,env',t,u),x)
+
+(** Ad-hoc reductions *)
+
+let j_nf_betaiotaevar sigma j =
+  { uj_val = Evarutil.nf_evar sigma j.uj_val;
+    uj_type = Reductionops.nf_betaiota sigma j.uj_type }
+
+let jv_nf_betaiotaevar sigma jl =
+  Array.map (j_nf_betaiotaevar sigma) jl
 
 (** Printers *)
 
@@ -136,9 +149,9 @@ let pr_explicit env sigma t1 t2 = pr_explicit_aux env sigma t1 t2 explicit_flags
 
 let pr_db env i =
   try
-    match lookup_rel i env with
-        Name id, _, _ -> pr_id id
-      | Anonymous, _, _ -> str "<>"
+    match lookup_rel i env |> get_name with
+      | Name id -> pr_id id
+      | Anonymous -> str "<>"
   with Not_found -> str "UNBOUND_REL_" ++ int i
 
 let explain_unbound_rel env sigma n =
@@ -260,7 +273,7 @@ let explain_generalization env sigma (name,var) j =
   str "it has type" ++ spc () ++ pt ++
   spc () ++ str "which should be Set, Prop or Type."
 
-let rec explain_unification_error env sigma p1 p2 = function
+let explain_unification_error env sigma p1 p2 = function
   | None -> mt()
   | Some e ->
      let rec aux p1 p2 = function
@@ -291,7 +304,8 @@ let rec explain_unification_error env sigma p1 p2 = function
         else []
      | MetaOccurInBody evk ->
         [str "instance for " ++ quote (pr_existential_key sigma evk) ++
-	strbrk " refers to a metavariable - please report your example"]
+	strbrk " refers to a metavariable - please report your example" ++
+        strbrk "at " ++ str Coq_config.wwwbugtracker ++ str "."]
      | InstanceNotSameType (evk,env,t,u) ->
         let t, u = pr_explicit env sigma t u in
         [str "unable to find a well-typed instantiation for " ++
@@ -307,9 +321,12 @@ let rec explain_unification_error env sigma p1 p2 = function
      | CannotSolveConstraint ((pb,env,t,u),e) ->
         let t = Evarutil.nf_evar sigma t in
         let u = Evarutil.nf_evar sigma u in
+        let env = make_all_name_different env in
         (strbrk "cannot satisfy constraint " ++ pr_lconstr_env env sigma t ++
         str " == " ++ pr_lconstr_env env sigma u)
         :: aux t u e
+     | ProblemBeyondCapabilities ->
+        []
      in
      match aux p1 p2 e with
      | [] -> mt ()
@@ -318,7 +335,7 @@ let rec explain_unification_error env sigma p1 p2 = function
 
 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 j = 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
@@ -333,7 +350,7 @@ let explain_actual_type env sigma j t reason =
   ppreason ++ str ".")
 
 let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl =
-  let randl = Evarutil.jv_nf_betaiotaevar sigma randl in
+  let randl = jv_nf_betaiotaevar sigma randl in
   let exptyp = Evarutil.nf_evar sigma exptyp in
   let actualtyp = Reductionops.nf_betaiota sigma actualtyp in
   let rator = Evarutil.j_nf_evar sigma rator in
@@ -481,7 +498,7 @@ let explain_ill_formed_rec_body env sigma err names i fixenv vdefj =
       let fixenv = make_all_name_different fixenv 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 ())
+    with e when CErrors.noncritical e -> mt ())
 
 let explain_ill_typed_rec_body env sigma i names vdefj vargs =
   let vdefj = Evarutil.jv_nf_evar sigma vdefj in
@@ -499,7 +516,8 @@ let explain_cant_find_case_type env sigma c =
   let c = Evarutil.nf_evar sigma c in
   let env = make_all_name_different env in
   let pe = pr_lconstr_env env sigma c in
-  str "Cannot infer type of pattern-matching on" ++ ws 1 ++ pe ++ str "."
+  str "Cannot infer the return type of pattern-matching on" ++ ws 1 ++
+    pe ++ str "."
 
 let explain_occur_check env sigma ev rhs =
   let rhs = Evarutil.nf_evar sigma rhs in
@@ -738,7 +756,7 @@ let pr_constraints printenv env sigma evars cstrs =
       let evs =
         prlist
         (fun (ev, evi) -> fnl () ++ pr_existential_key sigma ev ++
-            str " : " ++ pr_lconstr_env env' sigma evi.evar_concl) l
+            str " : " ++ pr_lconstr_env env' sigma evi.evar_concl ++ fnl ()) l
       in
       h 0 (pe ++ evs ++ pr_evar_constraints cstrs)
     else
@@ -775,7 +793,7 @@ let explain_unsatisfiable_constraints env sigma constr comp =
     explain_typeclass_resolution env sigma info k ++ fnl () ++ cstr
 
 let explain_pretype_error env sigma err =
-  let env = Evarutil.env_nf_betaiotaevar sigma env in
+  let env = Evardefine.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
@@ -822,7 +840,7 @@ let explain_not_match_error = function
   | ModuleTypeFieldExpected ->
     strbrk "a module type is expected"
   | NotConvertibleInductiveField id | NotConvertibleConstructorField id ->
-    str "types given to " ++ str (Id.to_string id) ++ str " differ"
+    str "types given to " ++ pr_id id ++ str " differ"
   | NotConvertibleBodyField ->
     str "the body of definitions differs"
   | NotConvertibleTypeField (env, typ1, typ2) ->
@@ -847,7 +865,7 @@ 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 (Id.to_string id) | _ -> str "_") nal
+    pr_enum (function Name id -> pr_id id | _ -> str "_") nal
   | NotEqualInductiveAliases ->
     str "Aliases to inductive types do not match"
   | NoTypeConstraintExpected ->
@@ -890,17 +908,27 @@ let explain_is_a_functor () =
   str "Illegal use of a functor."
 
 let explain_incompatible_module_types mexpr1 mexpr2 =
-  str "Incompatible module types."
+  let open Declarations in
+  let rec get_arg = function
+  | NoFunctor _ -> 0
+  | MoreFunctor (_, _, ty) -> succ (get_arg ty)
+  in
+  let len1 = get_arg mexpr1.mod_type in
+  let len2 = get_arg mexpr2.mod_type in
+  if len1 <> len2 then
+    str "Incompatible module types: module expects " ++ int len2 ++
+      str " arguments, found " ++ int len1 ++ str "."
+  else str "Incompatible module types."
 
 let explain_not_equal_module_paths mp1 mp2 =
   str "Non equal modules."
 
 let explain_no_such_label l =
-  str "No such label " ++ str (Label.to_string l) ++ str "."
+  str "No such label " ++ pr_label l ++ str "."
 
 let explain_incompatible_labels l l' =
   str "Opening and closing labels are not the same: " ++
-  str (Label.to_string l) ++ str " <> " ++ str (Label.to_string l') ++ str "!"
+  pr_label l ++ str " <> " ++ pr_label l' ++ str "!"
 
 let explain_not_a_module s =
   quote (str s) ++ str " is not a module."
@@ -909,19 +937,19 @@ let explain_not_a_module_type s =
   quote (str s) ++ str " is not a module type."
 
 let explain_not_a_constant l =
-  quote (Label.print l) ++ str " is not a constant."
+  quote (pr_label l) ++ str " is not a constant."
 
 let explain_incorrect_label_constraint l =
   str "Incorrect constraint for label " ++
-  quote (Label.print l) ++ str "."
+  quote (pr_label l) ++ str "."
 
 let explain_generative_module_expected l =
-  str "The module " ++ str (Label.to_string l) ++ str " is not generative." ++
+  str "The module " ++ pr_label 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 (Label.to_string l) ++ str " is missing in "
+  str "The field " ++ pr_label l ++ str " is missing in "
   ++ str s ++ str "."
 
 let explain_include_restricted_functor mp =
@@ -1122,6 +1150,11 @@ let error_not_allowed_case_analysis isrec kind i =
   strbrk " is not allowed for inductive definition " ++
   pr_inductive (Global.env()) (fst i) ++ str "."
 
+let error_not_allowed_dependent_analysis isrec i =
+  str "Dependent " ++ str (if isrec then "Induction" else "Case analysis") ++
+  strbrk " is not allowed for inductive definition " ++
+  pr_inductive (Global.env()) i ++ str "."
+
 let error_not_mutual_in_scheme ind ind' =
   if eq_ind ind ind' then
     str "The inductive type " ++ pr_inductive (Global.env()) ind ++
@@ -1153,6 +1186,8 @@ let explain_recursion_scheme_error = function
   | NotAllowedCaseAnalysis (isrec,k,i) ->
       error_not_allowed_case_analysis isrec k i
   | NotMutualInScheme (ind,ind')-> error_not_mutual_in_scheme ind ind'
+  | NotAllowedDependentAnalysis (isrec, i) ->
+     error_not_allowed_dependent_analysis isrec i
 
 (* Pattern-matching errors *)
 
@@ -1197,7 +1232,7 @@ let explain_unused_clause env pats =
 let explain_non_exhaustive env pats =
   str "Non exhaustive pattern-matching: no clause found for " ++
   str (String.plural (List.length pats) "pattern") ++
-  spc () ++ hov 0 (pr_sequence pr_cases_pattern pats)
+  spc () ++ hov 0 (prlist_with_sep pr_comma pr_cases_pattern pats)
 
 let explain_cannot_infer_predicate env sigma typs =
   let env = make_all_name_different env in
@@ -1230,77 +1265,3 @@ let explain_reduction_tactic_error = function
       quote (pr_goal_concl_style_env env sigma c) ++
       spc () ++ str "is not well typed." ++ fnl () ++
       explain_type_error env' Evd.empty e
-
-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
-  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
-    (* 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 3ef98380..ced54fd2 100644
--- a/toplevel/himsg.mli
+++ b/toplevel/himsg.mli
@@ -36,9 +36,6 @@ val explain_pattern_matching_error :
 val explain_reduction_tactic_error :
   Tacred.reduction_tactic_error -> 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
 
 val explain_module_internalization_error :
diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml
index 35717ed6..6d57a21d 100644
--- a/toplevel/ind_tables.ml
+++ b/toplevel/ind_tables.ml
@@ -18,7 +18,7 @@ open Libobject
 open Nameops
 open Declarations
 open Term
-open Errors
+open CErrors
 open Util
 open Declare
 open Entries
diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml
index c4ac0e41..e8ea617f 100644
--- a/toplevel/indschemes.ml
+++ b/toplevel/indschemes.ml
@@ -15,7 +15,7 @@
    declaring new schemes *)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Declarations
@@ -38,6 +38,7 @@ open Ind_tables
 open Auto_ind_decl
 open Eqschemes
 open Elimschemes
+open Context.Rel.Declaration
 
 (* Flags governing automatic synthesis of schemes *)
 
@@ -149,16 +150,18 @@ let alarm what internal msg =
   | UserAutomaticRequest
   | InternalTacticRequest ->
     (if debug then
-      msg_warning
-	(hov 0 msg ++ fnl () ++ what ++ str " not defined."))
-  | _ -> errorlabstrm "" msg
+      Feedback.msg_debug
+	(hov 0 msg ++ fnl () ++ what ++ str " not defined.")); None
+  | _ -> Some msg
 
 let try_declare_scheme what f internal names kn =
   try f internal names kn
-  with
+  with e ->
+  let e = CErrors.push e in
+  let msg = match fst e with
     | ParameterWithoutEquality cst ->
 	alarm what internal
-	  (str "Boolean equality not found for parameter " ++ pr_con cst ++
+	  (str "Boolean equality not found for parameter " ++ Printer.pr_global cst ++
 	   str".")
     | InductiveWithProduct ->
 	alarm what internal
@@ -183,9 +186,14 @@ let try_declare_scheme what f internal names kn =
     | DecidabilityMutualNotSupported ->
         alarm what internal
           (str "Decidability lemma for mutual inductive types not supported.")
-    | e when Errors.noncritical e ->
+    | e when CErrors.noncritical e ->
         alarm what internal
-	  (str "Unexpected error during scheme creation: " ++ Errors.print e)
+	  (str "Unexpected error during scheme creation: " ++ CErrors.print e)
+    | _ -> iraise e
+  in
+  match msg with
+  | None -> ()
+  | Some msg -> iraise (UserError ("", msg), snd e)
 
 let beq_scheme_msg mind =
   let mib = Global.lookup_mind mind in
@@ -209,7 +217,11 @@ 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 if not (Inductiveops.has_dependent_elim mib) then
+      case_scheme_kind_from_type
+    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
@@ -229,15 +241,23 @@ let kinds_from_type =
    InProp,ind_dep_scheme_kind_from_type;
    InSet,rec_dep_scheme_kind_from_type]
 
+let nondep_kinds_from_type =
+  [InType,rect_scheme_kind_from_type;
+   InProp,ind_scheme_kind_from_type;
+   InSet,rec_scheme_kind_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 depelim = Inductiveops.has_dependent_elim mib in
   let kelim = elim_sorts (mib,mip) in
   let elims =
     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
+      (if from_prop then kinds_from_prop
+       else if depelim then kinds_from_type
+       else nondep_kinds_from_type) in
   List.iter (fun kind -> ignore (define_individual_scheme kind UserAutomaticRequest None ind))
     elims
 
@@ -270,7 +290,7 @@ let try_declare_eq_decidability kn =
 let declare_eq_decidability = declare_eq_decidability_scheme_with []
 
 let ignore_error f x =
-  try ignore (f x) with e when Errors.noncritical e -> ()
+  try ignore (f x) with e when CErrors.noncritical e -> ()
 
 let declare_rewriting_schemes ind =
   if Hipattern.is_inductive_equality ind then begin
@@ -287,15 +307,20 @@ let declare_rewriting_schemes ind =
       (define_individual_scheme rew_l2r_forward_dep_scheme_kind UserAutomaticRequest None) ind
   end
 
+let warn_cannot_build_congruence =
+  CWarnings.create ~name:"cannot-build-congruence" ~category:"schemes"
+         (fun () ->
+          strbrk "Cannot build congruence scheme because eq is not found")
+
 let declare_congr_scheme ind =
   if Hipattern.is_equality_type (mkInd ind) then begin
     if
       try Coqlib.check_required_library Coqlib.logic_module_name; true
-      with e when Errors.noncritical e -> false
+      with e when CErrors.noncritical e -> false
     then
       ignore (define_individual_scheme congr_scheme_kind UserAutomaticRequest None ind)
     else
-      msg_warning (strbrk "Cannot build congruence scheme because eq is not found")
+      warn_cannot_build_congruence ()
   end
 
 let declare_sym_scheme ind =
@@ -379,7 +404,6 @@ let do_mutual_induction_scheme lnamedepindsort =
   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),Safe_typing.empty_private_constants) in
     let cst = define fi UserIndividualRequest sigma proof_output (Some decltype) in
     ConstRef cst :: lrecref
@@ -463,7 +487,7 @@ let build_combined_scheme env schemes =
   in
   let ctx, _ =
     list_split_rev_at prods
-      (List.rev_map (fun (x, y) -> x, None, y) ctx) in
+      (List.rev_map (fun (x, y) -> LocalAssum (x, y)) ctx) in
   let typ = it_mkProd_wo_LetIn concl_typ ctx in
   let body = it_mkLambda_or_LetIn concl_bod ctx in
   (body, typ)
@@ -489,7 +513,8 @@ let map_inductive_block f kn n = for i=0 to n-1 do f (kn,i) done
 let declare_default_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
+  if !elim_flag && (mib.mind_finite <> BiFinite || !bifinite_elim_flag)
+     && mib.mind_typing_flags.check_guarded 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;
diff --git a/toplevel/locality.ml b/toplevel/locality.ml
index ef789aa5..154f787e 100644
--- a/toplevel/locality.ml
+++ b/toplevel/locality.ml
@@ -18,7 +18,7 @@ let check_locality locality_flag =
   match locality_flag with
   | Some b ->
     let s = if b then "Local" else "Global" in
-    Errors.errorlabstrm "Locality.check_locality"
+    CErrors.errorlabstrm "Locality.check_locality"
       (str "This command does not support the \"" ++ str s ++ str "\" prefix.")
   | None -> ()
 
@@ -26,17 +26,22 @@ let check_locality locality_flag =
 
 (* Commands which supported an inlined Local flag *)
 
+let warn_deprecated_local_syntax =
+  CWarnings.create ~name:"deprecated-local-syntax" ~category:"deprecated"
+         (fun () ->
+          Pp.strbrk "Deprecated syntax: use \"Local\" as a prefix.")
+
 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."
+	CErrors.error "Cannot be simultaneously Local and Global."
     | Some true when local ->
-	Errors.error "Use only prefix \"Local\"."
+	CErrors.error "Use only prefix \"Local\"."
     | None ->
 	if local then begin
-          Pp.msg_warning (Pp.str "Obsolete syntax: use \"Local\" as a prefix.");
-	  Some true
+	    warn_deprecated_local_syntax ();
+	    Some true
 	end else
 	None
     | Some b -> Some b in
@@ -61,7 +66,7 @@ let enforce_locality_exp locality_flag local =
   | 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"
+  | Some _, Some _ -> CErrors.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;
@@ -82,7 +87,7 @@ let enforce_section_locality locality_flag local =
 let make_module_locality = function
   | Some false ->
       if Lib.sections_are_opened () then
-	Errors.error
+	CErrors.error
 	  "This command does not support the Global option in sections.";
       false
   | Some true -> true
diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml
index ae82b64e..008d5cf9 100644
--- a/toplevel/metasyntax.ml
+++ b/toplevel/metasyntax.ml
@@ -8,7 +8,7 @@
 
 open Pp
 open Flags
-open Errors
+open CErrors
 open Util
 open Names
 open Constrexpr
@@ -23,7 +23,6 @@ open Vernacexpr
 open Pcoq
 open Libnames
 open Tok
-open Egramml
 open Egramcoq
 open Notation
 open Nameops
@@ -31,7 +30,7 @@ open Nameops
 (**********************************************************************)
 (* Tokens                                                             *)
 
-let cache_token (_,s) = Lexer.add_keyword s
+let cache_token (_,s) = CLexer.add_keyword s
 
 let inToken : string -> obj =
   declare_object {(default_object "TOKEN") with
@@ -43,161 +42,6 @@ let inToken : string -> obj =
 let add_token_obj s = Lib.add_anonymous_leaf (inToken s)
 
 (**********************************************************************)
-(* Tactic Notation                                                    *)
-
-let interp_prod_item lev = function
-  | TacTerm s -> GramTerminal s
-  | TacNonTerm (loc, nt, po) ->
-      let sep = match po with Some (_,sep) -> sep | _ -> "" in
-      let (etyp, e) = interp_entry_name true (Some lev) nt sep in
-      GramNonTerminal (loc, etyp, e, Option.map fst po)
-
-let make_terminal_status = function
-  | GramTerminal s -> Some s
-  | GramNonTerminal _ -> None
-
-let rec make_tags = function
-  | GramTerminal s :: l -> make_tags l
-  | GramNonTerminal (loc, etyp, _, po) :: l -> etyp :: make_tags l
-  | [] -> []
-
-let make_fresh_key =
-  let id = Summary.ref ~name:"TACTIC-NOTATION-COUNTER" 0 in
-  fun () ->
-    let cur = incr id; !id in
-    let lbl = Id.of_string ("_" ^ string_of_int cur) in
-    let kn = Lib.make_kn lbl in
-    let (mp, dir, _) = KerName.repr kn in
-    (** We embed the full path of the kernel name in the label so that the
-        identifier should be unique. This ensures that including two modules
-        together won't confuse the corresponding labels. *)
-    let lbl = Id.of_string_soft (Printf.sprintf "%s#%s#%i"
-      (ModPath.to_string mp) (DirPath.to_string dir) cur)
-    in
-    KerName.make mp dir (Label.of_id lbl)
-
-type tactic_grammar_obj = {
-  tacobj_key : KerName.t;
-  tacobj_local : locality_flag;
-  tacobj_tacgram : tactic_grammar;
-  tacobj_tacpp : Pptactic.pp_tactic;
-  tacobj_body : Tacexpr.glob_tactic_expr
-}
-
-let check_key key =
-  if Tacenv.check_alias key then
-    error "Conflicting tactic notations keys. This can happen when including \
-    twice the same module."
-
-let cache_tactic_notation (_, tobj) =
-  let key = tobj.tacobj_key in
-  let () = check_key key in
-  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 open_tactic_notation i (_, tobj) =
-  let key = tobj.tacobj_key in
-  if Int.equal i 1 && not tobj.tacobj_local then
-    Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram
-
-let load_tactic_notation i (_, tobj) =
-  let key = tobj.tacobj_key in
-  let () = check_key key in
-  (** 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_key = Mod_subst.subst_kn subst tobj.tacobj_key;
-    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 = open_tactic_notation;
-       load_function = load_tactic_notation;
-       cache_function = cache_tactic_notation;
-       subst_function = subst_tactic_notation;
-       classify_function = classify_tactic_notation}
-
-let cons_production_parameter l = function
-  | GramTerminal _ -> l
-  | GramNonTerminal (_,_,_,ido) -> Option.List.cons ido l
-
-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 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 = Tacintern.glob_tactic_env ids (Global.env()) e in
-  let parule = {
-    tacgram_level = n;
-    tacgram_prods = prods;
-  } in
-  let tacobj = {
-    tacobj_key = make_fresh_key ();
-    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 entry_buf = Buffer.create 64
@@ -340,7 +184,7 @@ let parse_format ((loc, str) : lstring) =
     else
       error "Empty format."
   with reraise ->
-    let (e, info) = Errors.push reraise in
+    let (e, info) = CErrors.push reraise in
     let info = Loc.add_loc info loc in
     iraise (e, info)
 
@@ -428,7 +272,7 @@ 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 = Lexer.is_ident x in
+  let norm = CLexer.is_ident x in
   if (n > 0 && norm) || (n > 2 && x.[0] == '\'') then "'"^x^"'"
   else x
 
@@ -436,7 +280,7 @@ 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 Lexer.is_ident x ->
+  | String x :: sl when CLexer.is_ident x ->
       NonTerminal (Names.Id.of_string x) :: raw_analyze_notation_tokens sl
   | String s :: sl ->
       Terminal (String.drop_simple_quotes s) :: raw_analyze_notation_tokens sl
@@ -540,10 +384,15 @@ let add_break_if_none n = function
   | l -> UnpCut (PpBrk(n,0)) :: l
 
 let check_open_binder isopen sl m =
+  let pr_token = function
+  | Terminal s -> str s
+  | Break n -> str "␣"
+  | _ -> assert false
+  in
   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
+      prlist_with_sep spc pr_token sl
       ++ strbrk "\" is allowed to occur.")
 
 (* Heuristics for building default printing rules *)
@@ -719,8 +568,8 @@ 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 ->
-      Flags.if_verbose msg_info (str "Identifier '" ++ str k ++ str "' now a keyword");
-      Lexer.add_keyword k;
+      Flags.if_verbose Feedback.msg_info (str "Identifier '" ++ str k ++ str "' now a keyword");
+      CLexer.add_keyword k;
       n1 :: GramConstrTerminal(KEYWORD k) :: define_keywords_aux l
   | n :: l -> n :: define_keywords_aux l
   | [] -> []
@@ -728,8 +577,8 @@ let rec define_keywords_aux = function
   (* Ensure that IDENT articulation terminal symbols are keywords *)
 let define_keywords = function
   | GramConstrTerminal(IDENT k)::l ->
-      Flags.if_verbose msg_info (str "Identifier '" ++ str k ++ str "' now a keyword");
-      Lexer.add_keyword k;
+      Flags.if_verbose Feedback.msg_info (str "Identifier '" ++ str k ++ str "' now a keyword");
+      CLexer.add_keyword k;
       GramConstrTerminal(KEYWORD k) :: define_keywords_aux l
   | l -> define_keywords_aux l
 
@@ -758,12 +607,12 @@ let make_production etyps symbols =
 	    let typ = List.assoc m etyps in
 	    distribute [GramConstrNonTerminal (typ, Some m)] ll
         | Terminal s ->
-	    distribute [GramConstrTerminal (Lexer.terminal s)] ll
+	    distribute [GramConstrTerminal (CLexer.terminal s)] ll
         | Break _ ->
             ll
         | SProdList (x,sl) ->
             let tkl = List.flatten
-              (List.map (function Terminal s -> [Lexer.terminal s]
+              (List.map (function Terminal s -> [CLexer.terminal s]
                 | Break _ -> []
                 | _ -> anomaly (Pp.str "Found a non terminal token in recursive notation separator")) sl) in
 	    match List.assoc x etyps with
@@ -824,24 +673,32 @@ type syntax_extension = {
   synext_notgram : notation_grammar;
   synext_unparsing : unparsing list;
   synext_extra : (string * string) list;
+  synext_compat : Flags.compat_version option;
 }
 
+let is_active_compat = function
+| None -> true
+| Some v -> 0 <= Flags.version_compare v !Flags.compat_version
+
 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
+  let onlyprint = se.synext_notgram.notgram_onlyprinting in
   try
     let oldprec = Notation.level_of_notation ntn in
     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 *)
-    Egramcoq.extend_constr_grammar prec se.synext_notgram;
-    (* Declare the printing rule *)
-    Notation.declare_notation_printing_rule ntn
-      ~extra:se.synext_extra (se.synext_unparsing, fst prec)
+    if is_active_compat se.synext_compat then begin
+      (* Reserve the notation level *)
+      Notation.declare_notation_level ntn prec;
+      (* Declare the parsing rule *)
+      if not onlyprint then Egramcoq.extend_constr_grammar prec se.synext_notgram;
+      (* Declare the notation rule *)
+      Notation.declare_notation_rule ntn
+        ~extra:se.synext_extra (se.synext_unparsing, fst prec) se.synext_notgram
+    end
 
 let cache_syntax_extension (_, (_, sy)) =
   List.iter cache_one_syntax_extension sy
@@ -874,9 +731,11 @@ let inSyntaxExtension : syntax_extension_obj -> obj =
 
 let interp_modifiers modl =
   let onlyparsing = ref false in
+  let onlyprinting = ref false in
+  let compat = ref None in
   let rec interp assoc level etyps format extra = function
     | [] ->
-	(assoc,level,etyps,!onlyparsing,format,extra)
+	(assoc,level,etyps,!onlyparsing,!onlyprinting,!compat,format,extra)
     | SetEntryType (s,typ) :: l ->
 	let id = Id.of_string s in
 	if Id.List.mem_assoc id etyps then
@@ -898,9 +757,15 @@ let interp_modifiers modl =
     | SetAssoc a :: 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 ->
+    | SetOnlyParsing :: l ->
 	onlyparsing := true;
 	interp assoc level etyps format extra l
+    | SetOnlyPrinting :: l ->
+	onlyprinting := true;
+	interp assoc level etyps format extra l
+    | SetCompatVersion v :: l ->
+        compat := Some v;
+	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
@@ -909,7 +774,7 @@ let interp_modifiers modl =
   in interp None None [] None [] modl
 
 let check_infix_modifiers modifiers =
-  let (assoc,level,t,b,fmt,extra) = interp_modifiers modifiers in
+  let (_, _, t, _, _, _, _, _) = interp_modifiers modifiers in
   if not (List.is_empty t) then
     error "Explicit entry level or type unexpected in infix notation."
 
@@ -920,13 +785,25 @@ let check_useless_entry_types recvars mainvars etyps =
                   (pr_id x ++ str " is unbound in the notation.")
   | _ -> ()
 
-let no_syntax_modifiers = function
-  | [] | [SetOnlyParsing _] -> true
-  | _ -> false
+let not_a_syntax_modifier = function
+| SetOnlyParsing -> true
+| SetOnlyPrinting -> true
+| SetCompatVersion _ -> true
+| _ -> false
 
-let is_only_parsing = function
-  | [SetOnlyParsing _] -> true
-  | _ -> false
+let no_syntax_modifiers mods = List.for_all not_a_syntax_modifier mods
+
+let is_only_parsing mods =
+  let test = function SetOnlyParsing -> true | _ -> false in
+  List.exists test mods
+
+let is_only_printing mods =
+  let test = function SetOnlyPrinting -> true | _ -> false in
+  List.exists test mods
+
+let get_compat_version mods =
+  let test = function SetCompatVersion v -> Some v | _ -> None in
+  try Some (List.find_map test mods) with Not_found -> None
 
 (* Compute precedences from modifiers (or find default ones) *)
 
@@ -973,11 +850,12 @@ let make_internalization_vars recvars mainvars typs =
   let extratyps = List.map (fun (x,y) -> (y,List.assoc x maintyps)) recvars in
   maintyps @ extratyps
 
-let make_interpretation_type isrec = function
+let make_interpretation_type isrec isonlybinding = function
   | NtnInternTypeConstr when isrec -> NtnTypeConstrList
-  | NtnInternTypeConstr | NtnInternTypeIdent -> NtnTypeConstr
+  | NtnInternTypeConstr | NtnInternTypeIdent ->
+     if isonlybinding then NtnTypeOnlyBinder else NtnTypeConstr
   | NtnInternTypeBinder when isrec -> NtnTypeBinderList
-  | NtnInternTypeBinder -> error "Type not allowed in recursive notation."
+   | NtnInternTypeBinder -> error "Type binder is only for use in recursive notations for binders."
 
 let make_interpretation_vars recvars allvars =
   let eq_subscope (sc1, l1) (sc2, l2) =
@@ -985,45 +863,65 @@ let make_interpretation_vars recvars allvars =
     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
+    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 =
     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
+  Id.Map.mapi (fun x (isonlybinding, sc, typ) ->
+    (sc, make_interpretation_type (Id.List.mem_assoc x recvars) isonlybinding typ)) mainvars
 
 let check_rule_productivity l =
-  if List.for_all (function NonTerminal _ -> true | _ -> false) l then
+  if List.for_all (function NonTerminal _ | Break _ -> true | _ -> false) l then
     error "A notation must include at least one symbol.";
   if (match l with SProdList _ :: _ -> true | _ -> false) then
     error "A recursive notation must start with at least one symbol."
 
-let is_not_printable onlyparse noninjective = function
+let warn_notation_bound_to_variable =
+  CWarnings.create ~name:"notation-bound-to-variable" ~category:"parsing"
+         (fun () ->
+          strbrk "This notation will not be used for printing as it is bound to a single variable.")
+
+let warn_non_reversible_notation =
+  CWarnings.create ~name:"non-reversible-notation" ~category:"parsing"
+         (fun () ->
+          strbrk "This notation will not be used for printing as it is not reversible.")
+
+let is_not_printable onlyparse nonreversible = 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
+  if not onlyparse then warn_notation_bound_to_variable ();
   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
+   if not onlyparse && nonreversible then
+     (warn_non_reversible_notation (); true)
   else onlyparse
 
 let find_precedence lev etyps symbols =
-  match symbols with
-  | NonTerminal x :: _ ->
+  let first_symbol =
+    let rec aux = function
+      | Break _ :: t -> aux t
+      | h :: t -> h
+      | [] -> assert false (* rule is known to be productive *) in
+    aux symbols in
+  let last_is_terminal () =
+    let rec aux b = function
+      | Break _ :: t -> aux b t
+      | Terminal _ :: t -> aux true t
+      | _ :: t -> aux false t
+      | [] -> b in
+    aux false symbols in
+  match first_symbol with
+  | NonTerminal x ->
       (try match List.assoc x etyps with
 	| ETConstr _ ->
 	    error "The level of the leftmost non-terminal cannot be changed."
 	| ETName | ETBigint | ETReference ->
             begin match lev with
             | None ->
-	      ([msg_info,strbrk "Setting notation at level 0."],0)
+	      ([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."],0)
             | Some 0 ->
               ([],0)
             | _ ->
@@ -1039,11 +937,9 @@ let find_precedence lev etyps symbols =
 	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)
-      ->
+  | Terminal _ when last_is_terminal () ->
       if Option.is_empty lev then
-	([msg_info,strbrk "Setting notation at level 0."], 0)
+	([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."], 0)
       else [],Option.get lev
   | _ ->
       if Option.is_empty lev then error "Cannot determine the level.";
@@ -1055,6 +951,10 @@ let check_curly_brackets_notation_exists () =
     error "Notations involving patterns of the form \"{ _ }\" are treated \n\
 specially and require that the notation \"{ _ }\" is already reserved."
 
+let warn_skip_spaces_curly =
+  CWarnings.create ~name:"skip-spaces-curly" ~category:"parsing"
+      (fun () ->strbrk "Skipping spaces inside curly brackets")
+
 (* Remove patterns of the form "{ _ }", unless it is the "{ _ }" notation *)
 let remove_curly_brackets l =
   let rec skip_break acc = function
@@ -1069,9 +969,10 @@ let remove_curly_brackets l =
             let br',next' = skip_break [] l' in
             (match next' with
               | Terminal "}" as t2 :: l'' as l1 ->
-                  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
+                 if not (List.equal Notation.symbol_eq l l0) ||
+		      not (List.equal Notation.symbol_eq l' l1) then
+		  warn_skip_spaces_curly ();
+		  if deb && List.is_empty l'' then [t1;x;t2] else begin
                     check_curly_brackets_notation_exists ();
                     x :: aux false l''
                   end
@@ -1081,7 +982,7 @@ let remove_curly_brackets l =
   in aux true l
 
 let compute_syntax_data df modifiers =
-  let (assoc,n,etyps,onlyparse,fmt,extra) = interp_modifiers modifiers in
+  let (assoc,n,etyps,onlyparse,onlyprint,compat,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
@@ -1107,18 +1008,18 @@ let compute_syntax_data df modifiers =
   let sy_data = (n,sy_typs,symbols',fmt) in
   let sy_fulldata = (i_typs,ntn_for_grammar,prec,need_squash,sy_data) in
   let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in
-  let i_data = (onlyparse,recvars,mainvars,(ntn_for_interp,df')) in
+  let i_data = (onlyparse,onlyprint,compat,recvars,mainvars,(ntn_for_interp,df')) in
   (* Return relevant data for interpretation and for parsing/printing *)
   (msgs,i_data,i_typs,sy_fulldata,extra)
 
 let compute_pure_syntax_data df mods =
-  let (msgs,(onlyparse,_,_,_),_,sy_data,extra) = compute_syntax_data df mods in
+  let (msgs,(onlyparse,onlyprint,_,_,_,_),_,sy_data,extra) = compute_syntax_data df mods in
   let msgs =
     if onlyparse then
-      (msg_warning,
+      (Feedback.msg_warning ?loc:None,
       strbrk "The only parsing modifier has no effect in Reserved Notation.")::msgs
     else msgs in
-  msgs, sy_data, extra
+  msgs, sy_data, extra, onlyprint
 
 (**********************************************************************)
 (* Registration of notations interpretation                            *)
@@ -1128,6 +1029,8 @@ type notation_obj = {
   notobj_scope : scope_name option;
   notobj_interp : interpretation;
   notobj_onlyparse : bool;
+  notobj_onlyprint : bool;
+  notobj_compat : Flags.compat_version option;
   notobj_notation : notation * notation_location;
 }
 
@@ -1138,9 +1041,12 @@ 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 && not (Notation.exists_notation_in_scope scope ntn pat) then begin
+  let fresh = not (Notation.exists_notation_in_scope scope ntn pat) in
+  let active = is_active_compat nobj.notobj_compat in
+  if Int.equal i 1 && fresh && active then begin
     (* Declare the interpretation *)
-    Notation.declare_notation_interpretation ntn scope pat df;
+    let onlyprint = nobj.notobj_onlyprint  in
+    let () = Notation.declare_notation_interpretation ntn scope pat df ~onlyprint in
     (* Declare the uninterpretation *)
     if not nobj.notobj_onlyparse then
       Notation.declare_uninterpretation (NotationRule (scope, ntn)) pat
@@ -1170,7 +1076,7 @@ let with_lib_stk_protection f x =
   let fs = Lib.freeze `No in
   try let a = f x in Lib.unfreeze fs; a
   with reraise ->
-    let reraise = Errors.push reraise in
+    let reraise = CErrors.push reraise in
     let () = Lib.unfreeze fs in
     iraise reraise
 
@@ -1187,7 +1093,10 @@ let contract_notation ntn =
   let rec aux ntn i =
     if i <= String.length ntn - 5 then
       let ntn' =
-        if String.is_sub "{ _ }" ntn i then
+        if String.is_sub "{ _ }" ntn i &&
+           (i = 0 || ntn.[i-1] = ' ') &&
+           (i = String.length ntn - 5 || ntn.[i+5] = ' ')
+        then
           String.sub ntn 0 i ^ "_" ^
           String.sub ntn (i+5) (String.length ntn -i-5)
         else ntn in
@@ -1202,12 +1111,14 @@ let recover_syntax ntn =
     let prec = Notation.level_of_notation ntn in
     let pp_rule,_ = Notation.find_notation_printing_rule ntn in
     let pp_extra_rules = Notation.find_notation_extra_printing_rules ntn in
-    let pa_rule = Egramcoq.recover_constr_grammar ntn prec in
+    let pa_rule = Notation.find_notation_parsing_rules ntn in
     { synext_level = prec;
       synext_notation = ntn;
       synext_notgram = pa_rule;
       synext_unparsing = pp_rule;
-      synext_extra = pp_extra_rules }
+      synext_extra = pp_extra_rules;
+      synext_compat = None;
+    }
   with Not_found ->
     raise NoSyntaxRule
 
@@ -1220,27 +1131,29 @@ let recover_notation_syntax rawntn =
   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
+  sy.synext_notgram.notgram_typs, rules, sy.synext_notgram.notgram_onlyprinting
 
 (**********************************************************************)
 (* Main entry point for building parsing and printing rules           *)
 
-let make_pa_rule i_typs (n,typs,symbols,_) ntn =
+let make_pa_rule i_typs (n,typs,symbols,_) ntn onlyprint =
   let assoc = recompute_assoc typs in
   let prod = make_production typs symbols in
   { notgram_level = n;
     notgram_assoc = assoc;
     notgram_notation = ntn;
     notgram_prods = prod;
-    notgram_typs = i_typs; }
+    notgram_typs = i_typs;
+    notgram_onlyprinting = onlyprint;
+  }
 
 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)
 
-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 make_syntax_rules (i_typs,ntn,prec,need_squash,sy_data) extra onlyprint compat =
+  let pa_rule = make_pa_rule i_typs sy_data ntn onlyprint in
   let pp_rule = make_pp_rule sy_data in
   let sy = {
     synext_level = prec;
@@ -1248,6 +1161,7 @@ let make_syntax_rules (i_typs,ntn,prec,need_squash,sy_data) extra =
     synext_notgram = pa_rule;
     synext_unparsing = pp_rule;
     synext_extra = extra;
+    synext_compat = compat;
   } 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
@@ -1263,26 +1177,27 @@ let to_map l =
 
 let add_notation_in_scope local df c mods scope =
   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 extra in
   (* Prepare the interpretation *)
-  let (onlyparse, recvars,mainvars, df') = i_data in
+  let (onlyparse, onlyprint, compat, recvars,mainvars, df') = i_data in
+  (* Prepare the parsing and printing rules *)
+  let sy_rules = make_syntax_rules sy_data extra onlyprint compat in
   let i_vars = make_internalization_vars recvars mainvars i_typs 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 (acvars, ac, reversible) = 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 onlyparse = is_not_printable onlyparse (not reversible) 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_onlyprint = onlyprint;
+    notobj_compat = compat;
     notobj_notation = df';
   } in
   (* Ready to change the global state *)
@@ -1291,14 +1206,17 @@ let add_notation_in_scope local df c mods scope =
   Lib.add_anonymous_leaf (inNotation notation);
   df'
 
-let add_notation_interpretation_core local df ?(impls=empty_internalization_env) c scope onlyparse =
+let add_notation_interpretation_core local df ?(impls=empty_internalization_env) c scope onlyparse onlyprint compat =
   let dfs = split_notation_string df in
   let (recvars,mainvars,symbs) = analyze_notation_tokens dfs in
   (* Recover types of variables and pa/pp rules; redeclare them if needed *)
-  let i_typs = if not (is_numeral symbs) then begin
-    let i_typs,sy_rules = recover_notation_syntax (make_notation_key symbs) in
-    Lib.add_anonymous_leaf (inSyntaxExtension (local,sy_rules)); i_typs
-  end else [] in
+  let i_typs, onlyprint = if not (is_numeral symbs) then begin
+    let i_typs,sy_rules,onlyprint' = recover_notation_syntax (make_notation_key symbs) in
+    let () = Lib.add_anonymous_leaf (inSyntaxExtension (local,sy_rules)) in
+    (** If the only printing flag has been explicitly requested, put it back *)
+    let onlyprint = onlyprint || onlyprint' in
+    i_typs, onlyprint
+  end else [], false in
   (* Declare interpretation *)
   let path = (Lib.library_dp(),Lib.current_dirpath true) in
   let df' = (make_notation_key symbs,(path,df)) in
@@ -1306,18 +1224,19 @@ let add_notation_interpretation_core local df ?(impls=empty_internalization_env)
   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 (acvars, ac, reversible) = 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 onlyparse = is_not_printable onlyparse (not reversible) 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_onlyprint = onlyprint;
+    notobj_compat = compat;
     notobj_notation = df';
   } in
   Lib.add_anonymous_leaf (inNotation notation);
@@ -1326,20 +1245,20 @@ let add_notation_interpretation_core local df ?(impls=empty_internalization_env)
 (* Notations without interpretation (Reserved Notation) *)
 
 let add_syntax_extension local ((loc,df),mods) =
-  let msgs, sy_data, extra = compute_pure_syntax_data df mods in
-  let sy_rules = make_syntax_rules sy_data extra in
+  let msgs, sy_data, extra, onlyprint = compute_pure_syntax_data df mods in
+  let sy_rules = make_syntax_rules sy_data extra onlyprint None in
   Flags.if_verbose (List.iter (fun (f,x) -> f x)) msgs;
   Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules))
 
 (* Notations with only interpretation *)
 
 let add_notation_interpretation ((loc,df),c,sc) =
-  let df' = add_notation_interpretation_core false df c sc false in
+  let df' = add_notation_interpretation_core false df c sc false false None in
   Dumpglob.dump_notation (loc,df') sc true
 
 let set_notation_for_interpretation impls ((_,df),c,sc) =
   (try ignore
-    (silently (add_notation_interpretation_core false df ~impls c sc) false);
+    (silently (fun () -> add_notation_interpretation_core false df ~impls c sc false false None) ());
   with NoSyntaxRule ->
     error "Parsing rule for this notation has to be previously declared.");
   Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc
@@ -1351,7 +1270,9 @@ let add_notation local c ((loc,df),modifiers) sc =
    if no_syntax_modifiers modifiers then
     (* No syntax data: try to rely on a previously declared rule *)
     let onlyparse = is_only_parsing modifiers in
-    try add_notation_interpretation_core local df c sc onlyparse
+    let onlyprint = is_only_printing modifiers in
+    let compat = get_compat_version modifiers in
+    try add_notation_interpretation_core local df c sc onlyparse onlyprint compat
     with NoSyntaxRule ->
       (* Try to determine a default syntax rule *)
       add_notation_in_scope local df c modifiers sc
@@ -1444,11 +1365,10 @@ let add_syntactic_definition ident (vars,c) local onlyparse =
       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
+      let nvars, pat, reversible = interp_notation_constr nenv c in
+      let () = nonprintable := not reversible 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
diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli
index ffebd07d..085cc87c 100644
--- a/toplevel/metasyntax.mli
+++ b/toplevel/metasyntax.mli
@@ -15,17 +15,6 @@ open Notation_term
 
 val add_token_obj : string -> unit
 
-(** Adding a tactic notation in the environment *)
-
-val add_tactic_notation :
-  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*)
 
 val add_infix : locality_flag -> (lstring * syntax_modifier list) ->
diff --git a/toplevel/mltop.ml b/toplevel/mltop.ml
index 0b6d93d6..b6690fe4 100644
--- a/toplevel/mltop.ml
+++ b/toplevel/mltop.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Errors
+open CErrors
 open Util
 open Pp
 open Flags
@@ -45,12 +45,12 @@ open System
    to build a dummy dynlink.cmxa, cf. dev/dynlink.ml. *)
 
 (* This path is where we look for .cmo *)
-let coq_mlpath_copy = ref ["."]
+let coq_mlpath_copy = ref [Sys.getcwd ()]
 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'))
+  let filter path' = not (String.equal cpath path')
   in
-  coq_mlpath_copy := path :: List.filter filter !coq_mlpath_copy
+  coq_mlpath_copy := cpath :: List.filter filter !coq_mlpath_copy
 
 (* If there is a toplevel under Coq *)
 type toplevel = {
@@ -118,8 +118,8 @@ let ml_load s =
     | WithTop t ->
       (try t.load_obj s; s
        with
-       | e when Errors.noncritical e ->
-        let e = Errors.push e in
+       | e when CErrors.noncritical e ->
+        let e = CErrors.push e in
         match fst e with
         | (UserError _ | Failure _ | Not_found as u) -> Exninfo.iraise (u, snd e)
         | exc ->
@@ -146,7 +146,12 @@ let dir_ml_load s =
 let dir_ml_use s =
   match !load with
     | WithTop t -> t.use_file s
-    | _ -> msg_warning (str "Cannot access the ML compiler")
+    | _ ->
+       let moreinfo =
+	 if Dynlink.is_native then " Loading ML code works only in bytecode."
+	 else ""
+       in
+      errorlabstrm "Mltop.dir_ml_use" (str "Could not load ML code." ++ str moreinfo)
 
 (* Adds a path to the ML paths *)
 let add_ml_dir s =
@@ -155,19 +160,31 @@ let add_ml_dir s =
     | WithoutTop when has_dynlink -> keep_copy_mlpath s
     | _ -> ()
 
-(* For Rec Add ML Path *)
+(* For Rec Add ML Path (-R) *)
 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 warn_cannot_use_directory =
+  CWarnings.create ~name:"cannot-use-directory" ~category:"filesystem"
+         (fun d ->
+          str "Directory " ++ str d ++
+            strbrk " cannot be used as a Coq identifier (skipped)")
+
 let convert_string d =
   try Names.Id.of_string d
   with UserError _ ->
-    msg_warning (str "Directory " ++ str d ++ str " cannot be used as a Coq identifier (skipped)");
+    warn_cannot_use_directory d;
     raise Exit
 
-let add_rec_path ~unix_path ~coq_root ~implicit =
+let warn_cannot_open_path =
+  CWarnings.create ~name:"cannot-open-path" ~category:"filesystem"
+      (fun unix_path -> str "Cannot open " ++ str unix_path)
+
+type add_ml = AddNoML | AddTopML | AddRecML
+
+let add_rec_path add_ml ~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
@@ -178,13 +195,16 @@ let add_rec_path ~unix_path ~coq_root ~implicit =
       with Exit -> None
     in
     let dirs = List.map_filter convert_dirs dirs in
-    let () = add_ml_dir unix_path in
+    let () = match add_ml with
+      | AddNoML -> ()
+      | AddTopML -> add_ml_dir unix_path
+      | AddRecML -> List.iter (fun (lp,_) -> add_ml_dir lp) dirs in
     let add (path, dir) =
       Loadpath.add_load_path path ~implicit dir in
     let () = List.iter add dirs in
     Loadpath.add_load_path unix_path ~implicit coq_root
   else
-    msg_warning (str "Cannot open " ++ str unix_path)
+    warn_cannot_open_path unix_path
 
 (* convertit un nom quelconque en nom de fichier ou de module *)
 let mod_of_name name =
@@ -324,10 +344,10 @@ let if_verbose_load verb f name ?path fname =
     let info = str "[Loading ML file " ++ str fname ++ str " ..." in
     try
       let path = f name ?path fname in
-      msg_info (info ++ str " done]");
+      Feedback.msg_info (info ++ str " done]");
       path
     with reraise ->
-      msg_info (info ++ str " failed]");
+      Feedback.msg_info (info ++ str " failed]");
       raise reraise
 
 (** Load a module for the first time (i.e. dynlink it)
@@ -391,7 +411,7 @@ let inMLModule : ml_module_object -> obj =
 
 let declare_ml_modules local l =
   let l = List.map mod_of_name l in
-  Lib.add_anonymous_leaf (inMLModule {mlocal=local; mnames=l})
+  Lib.add_anonymous_leaf ~cache_first:false (inMLModule {mlocal=local; mnames=l})
 
 let print_ml_path () =
   let l = !coq_mlpath_copy in
diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli
index 5d054682..6633cb93 100644
--- a/toplevel/mltop.mli
+++ b/toplevel/mltop.mli
@@ -46,8 +46,10 @@ val dir_ml_use : string -> unit
 val add_ml_dir : string -> unit
 val add_rec_ml_dir : string -> unit
 
+type add_ml = AddNoML | AddTopML | AddRecML
+
 (** Adds a path to the Coq and ML paths *)
-val add_rec_path : unix_path:string -> coq_root:Names.DirPath.t -> implicit:bool -> unit
+val add_rec_path : add_ml -> unix_path:string -> coq_root:Names.DirPath.t -> implicit:bool -> unit
 
 (** List of modules linked to the toplevel *)
 val add_known_module : string -> unit
diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml
index 314789ce..29d74573 100644
--- a/toplevel/obligations.ml
+++ b/toplevel/obligations.ml
@@ -13,21 +13,16 @@ open Declare
 *)
 
 open Term
-open Context
 open Vars
 open Names
 open Evd
 open Pp
-open Errors
+open CErrors
 open Util
 
 let declare_fix_ref = ref (fun ?opaque _ _ _ _ _ _ -> 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)
 
@@ -44,21 +39,19 @@ let check_evars env evm =
 
 type oblinfo =
   { ev_name: int * Id.t;
-    ev_hyps: named_context;
-    ev_status: Evar_kinds.obligation_definition_status;
+    ev_hyps: Context.Named.t;
+    ev_status: bool * 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 subst_evar_constr evs n idf t =
+  let open Context.Named.Declaration in
   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
@@ -82,9 +75,9 @@ let subst_evar_constr evs n idf t =
 	let args =
 	  let rec aux hyps args acc =
 	     match hyps, args with
-		 ((_, None, _) :: tlh), (c :: tla) ->
+		 (LocalAssum _ :: tlh), (c :: tla) ->
 		   aux tlh tla ((substrec (depth, fixrels) c) :: acc)
-	       | ((_, Some _, _) :: tlh), (_ :: tla) ->
+	       | (LocalDef _ :: tlh), (_ :: tla) ->
 		   aux tlh tla acc
 	       | [], [] -> acc
 	       | _, _ -> acc (*failwith "subst_evars: invalid argument"*)
@@ -120,22 +113,23 @@ let subst_vars acc n t =
     Changes evars and hypothesis references to variable references.
 *)
 let etype_of_evar evs hyps concl =
+  let open Context.Named.Declaration in
   let rec aux acc n = function
-      (id, copt, t) :: tl ->
-	let t', s, trans = subst_evar_constr evs n mkVar t in
+      decl :: tl ->
+	let t', s, trans = subst_evar_constr evs n mkVar (get_type decl) in
 	let t'' = subst_vars acc 0 t' in
-	let rest, s', trans' = aux (id :: acc) (succ n) tl in
+	let rest, s', trans' = aux (get_id decl :: 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 -> 
+	  (match decl with
+            | LocalDef (id,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,
+		  mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest,
 		Int.Set.union s'' s',
 		Id.Set.union trans'' trans'
-	    | None ->
-		mkNamedProd_or_LetIn (id, None, t'') rest, s', trans')
+	    | LocalAssum (id,_) ->
+		mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans')
     | [] ->
 	let t', s, trans = subst_evar_constr evs n mkVar concl in
 	  subst_vars acc 0 t', s, trans
@@ -194,7 +188,7 @@ 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 nc_len = Context.Named.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
@@ -221,25 +215,21 @@ let eterm_obligations env name evm fs ?status t ty =
 	   | 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
+	 let status = match k with
+           | Evar_kinds.QuestionMark o -> o
+           | _ -> match status with
+                 | Some o -> o
+                 | None -> Evar_kinds.Define (not (Program.get_proofs_transparency ()))
+         in
+         let force_status, status, chop = match status with
+	   | Evar_kinds.Define true as stat ->
+	      if not (Int.equal chop fs) then true, Evar_kinds.Define false, None
+	      else false, stat, Some chop
+	   | s -> false, s, 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 }
+		      ev_hyps = hyps; ev_status = force_status, status; ev_chop = chop;
+		      ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = None }
 	 in (id, info) :: l)
       evn []
   in
@@ -249,14 +239,14 @@ let eterm_obligations env name evm fs ?status t ty =
   let ty, _, _ = subst_evar_constr evts 0 mkVar ty in
   let evars = 
     List.map (fun (ev, info) ->
-      let { ev_name = (_, name); ev_status = status;
+      let { ev_name = (_, name); ev_status = force_status, status;
 	    ev_src = src; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info
       in
-      let status = match status with
+      let force_status, 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
+	  true, Evar_kinds.Define false
+	| _ -> force_status, status
+      in name, typ, src, (force_status, 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
@@ -268,21 +258,22 @@ let safe_init_constant md name () =
   Coqlib.gen_constant "Obligations" md name
 let hide_obligation = safe_init_constant tactics_module "obligation"
 
-let pperror cmd = Errors.errorlabstrm "Program" cmd
+let pperror cmd = CErrors.errorlabstrm "Program" cmd
 let error s = pperror (str s)
 
 let reduce c =
-  Reductionops.clos_norm_flags Closure.betaiota (Global.env ()) Evd.empty c
+  Reductionops.clos_norm_flags CClosure.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)
+    Some ident -> str "No obligations for program " ++ Id.print 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
+       (bool * Evar_kinds.obligation_definition_status)
+       * Int.Set.t * unit Proofview.tactic option) array
 
 type 'a obligation_body = 
   | DefinedObl of 'a
@@ -293,7 +284,7 @@ type obligation =
     obl_type : types;
     obl_location : Evar_kinds.t Loc.located;
     obl_body : constant obligation_body option;
-    obl_status : Evar_kinds.obligation_definition_status;
+    obl_status : bool * Evar_kinds.obligation_definition_status;
     obl_deps : Int.Set.t;
     obl_tac : unit Proofview.tactic option;
   }
@@ -311,6 +302,7 @@ type program_info_aux = {
   prg_body: constr;
   prg_type: constr;
   prg_ctx:  Evd.evar_universe_context;
+  prg_pl: Id.t Loc.located list option;
   prg_obligations: obligations;
   prg_deps : Id.t list;
   prg_fixkind : fixpoint_kind option ;
@@ -323,34 +315,16 @@ type program_info_aux = {
   prg_sign: named_context_val;
 }
 
-type program_info = program_info_aux Ephemeron.key
+type program_info = program_info_aux CEphemeron.key
 
 let get_info x =
-  try Ephemeron.get x
-  with Ephemeron.InvalidKey ->
-    Errors.anomaly Pp.(str "Program obligation can't be accessed by a worker")
+  try CEphemeron.get x
+  with CEphemeron.InvalidKey ->
+    CErrors.anomaly Pp.(str "Program obligation can't be accessed by a worker")
 
 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; }
+let default_tactic = ref (Proofview.tclUNIT ())
 
 (* true = hide obligations *)
 let hide_obligations = ref false
@@ -358,6 +332,7 @@ 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;
@@ -367,7 +342,7 @@ let _ =
       optread  = get_hide_obligations;
       optwrite = set_hide_obligations; }
 
-let shrink_obligations = ref false
+let shrink_obligations = ref true
 
 let set_shrink_obligations = (:=) shrink_obligations
 let get_shrink_obligations () = !shrink_obligations
@@ -375,7 +350,7 @@ let get_shrink_obligations () = !shrink_obligations
 let _ =
   declare_bool_option
     { optsync  = true;
-      optdepr  = false;
+      optdepr  = true;
       optname  = "Shrinking of Program obligations";
       optkey   = ["Shrink";"Obligations"];
       optread  = get_shrink_obligations;
@@ -383,36 +358,35 @@ let _ =
 
 let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type
 
-let get_body obl = 
+let get_body obl =
   match obl.obl_body with
-  | None -> assert false
+  | None -> None
   | 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
+      Some (DefinedObl pc)
+  | Some (TermObl c) ->
+      Some (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'
+  match get_body obl with
+  | None -> None
+  | Some c ->
+     if expand && snd obl.obl_status == Evar_kinds.Expand then
+       match c with
+       | DefinedObl pc -> Some (constant_value_in (Global.env ()) pc)
+       | TermObl c -> Some c
+     else (match c with
+	   | DefinedObl pc -> Some (mkConstU pc)
+	   | TermObl c -> Some 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)
+       match get_obligation_body expand xobl with
+       | None -> acc
+       | Some oblb -> (xobl.obl_name, (xobl.obl_type, oblb)) :: acc)
     deps []
 
 let subst_deps expand obls deps t =
@@ -458,9 +432,9 @@ 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)
+module ProgMap = Id.Map
 
-let map_replace k v m = ProgMap.add k (Ephemeron.create v) (ProgMap.remove k m)
+let map_replace k v m = ProgMap.add k (CEphemeron.create v) (ProgMap.remove k m)
 
 let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m []
 
@@ -510,15 +484,21 @@ let declare_definition prg =
     (Evd.evar_universe_context_subst prg.prg_ctx) in
   let opaque = prg.prg_opaque in
   let fix_exn = Stm.get_fix_exn () in
+  let pl, ctx =
+    Evd.universe_context ?names:prg.prg_pl (Evd.from_ctx prg.prg_ctx) in
   let ce =
     definition_entry ~fix_exn
      ~opaque ~types:(nf typ) ~poly:(pi2 prg.prg_kind)
      ~univs:(Evd.evar_context_universe_context prg.prg_ctx) (nf body)
   in
-    progmap_remove prg;
+  let () = progmap_remove prg in
+  let cst =
     !declare_definition_ref prg.prg_name 
-      prg.prg_kind ce prg.prg_implicits
-      (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r prg.prg_ctx; r))
+     prg.prg_kind ce prg.prg_implicits
+     (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r prg.prg_ctx; r))
+  in
+  Universes.register_universe_binders cst pl;
+  cst
       
 open Pp
 
@@ -539,7 +519,7 @@ let compute_possible_guardness_evidences (n,_) fixbody fixtype =
 	 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 m = Termops.nb_prod fixtype in
       let ctx = fst (decompose_prod_n_assum m fixtype) in
 	List.map_i (fun i _ -> i) 0 ctx
 
@@ -571,7 +551,8 @@ let declare_mutual_definition l =
 	    List.map3 compute_possible_guardness_evidences
               wfl fixdefs fixtypes in
 	  let indexes = 
-            Pretyping.search_guard Loc.ghost (Global.env())
+              Pretyping.search_guard
+              Loc.ghost (Global.env())
               possible_indexes fixdecls in
           Some indexes, 
           List.map_i (fun i _ ->
@@ -594,15 +575,49 @@ let declare_mutual_definition l =
     Lemmas.call_hook fix_exn first.prg_hook local gr first.prg_ctx;
     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 decompose_lam_prod c ty =
+  let open Context.Rel.Declaration in
+  let rec aux ctx c ty =
+    match kind_of_term c, kind_of_term ty with
+    | LetIn (x, b, t, c), LetIn (x', b', t', ty)
+	 when eq_constr b b' && eq_constr t t' ->
+       let ctx' = Context.Rel.add (LocalDef (x,b',t')) ctx in
+       aux ctx' c ty
+    | _, LetIn (x', b', t', ty) ->
+       let ctx' = Context.Rel.add (LocalDef (x',b',t')) ctx in
+       aux ctx' (lift 1 c) ty
+    | LetIn (x, b, t, c), _ ->
+       let ctx' = Context.Rel.add (LocalDef (x,b,t)) ctx in
+       aux ctx' c (lift 1 ty)
+    | Lambda (x, b, t), Prod (x', b', t')
+       (* By invariant, must be convertible *) ->
+       let ctx' = Context.Rel.add (LocalAssum (x,b')) ctx in
+       aux ctx' t t'
+    | Cast (c, _, _), _ -> aux ctx c ty
+    | _, _ -> ctx, c, ty
+  in aux Context.Rel.empty c ty
+
+let shrink_body c ty =
+  let open Context.Rel.Declaration in
+  let ctx, b, ty =
+    match ty with
+    | None ->
+       let ctx, b = decompose_lam_assum c in
+       ctx, b, None
+    | Some ty ->
+       let ctx, b, ty = decompose_lam_prod c ty in
+       ctx, b, Some ty
+  in
+  let b', ty', n, args =
+    List.fold_left (fun (b, ty, i, args) decl ->
+        if noccurn 1 b && Option.cata (noccurn 1) true ty then
+	  subst1 mkProp b, Option.map (subst1 mkProp) ty, succ i, args
+	else
+	  let args = if is_local_assum decl then mkRel i :: args else args in
+          mkLambda_or_LetIn decl b, Option.map (mkProd_or_LetIn decl) ty,
+	  succ i, args)
+     (b, ty, 1, []) ctx
+  in ctx, b', ty', Array.of_list args
 
 let unfold_entry cst = Hints.HintsUnfoldEntry [EvalConstRef cst]
 
@@ -613,46 +628,47 @@ 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 -> false, { obl with obl_body = Some (TermObl body) }
-  | Evar_kinds.Define opaque ->
-      let opaque = if get_proofs_transparency () then false else opaque in
+  | _, Evar_kinds.Expand -> false, { obl with obl_body = Some (TermObl body) }
+  | force, Evar_kinds.Define opaque ->
+      let opaque = not force && opaque in
       let poly = pi2 prg.prg_kind in
-      let ctx, body, args = 
+      let ctx, body, ty, args =
 	if get_shrink_obligations () && not poly then
-	  shrink_body body else [], body, [||] 
+	  shrink_body body ty else [], body, ty, [||]
       in
       let body = ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in
-      let ce = 
+      let ce =
         { const_entry_body = Future.from_val ~fix_exn:(fun x -> x) body;
           const_entry_secctx = None;
-	  const_entry_type = if List.is_empty ctx then ty else None;
+	  const_entry_type = ty;
 	  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 *)
+      (** 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 add_hint false prg constant;
 	definition_message obl.obl_name;
 	true, { obl with obl_body =
-	    if poly then 
+	    if poly then
 	      Some (DefinedObl constant)
 	    else
 	      Some (TermObl (it_mkLambda_or_LetIn (mkApp (mkConst constant, args)) ctx)) }
 
-let init_prog_info ?(opaque = false) sign n b t ctx deps fixkind notations obls impls kind reduce hook =
-  let obls', b = 
+let init_prog_info ?(opaque = false) sign n pl 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_status = false, Evar_kinds.Expand; obl_deps = Int.Set.empty;
 	       obl_tac = None } |],
 	mkVar n
     | Some b ->
@@ -664,7 +680,7 @@ let init_prog_info ?(opaque = false) sign n b t ctx deps fixkind notations obls
 	  obls, b
   in
     { prg_name = n ; prg_body = b; prg_type = reduce t; 
-      prg_ctx = ctx; 
+      prg_ctx = ctx; prg_pl = pl;
       prg_obligations = (obls', Array.length obls');
       prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ;
       prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; 
@@ -674,7 +690,7 @@ let init_prog_info ?(opaque = false) sign n b t ctx deps fixkind notations obls
 let map_cardinal m =
   let i = ref 0 in
   ProgMap.iter (fun _ v ->
-		if snd (Ephemeron.get v).prg_obligations > 0 then incr i) m;
+		if snd (CEphemeron.get v).prg_obligations > 0 then incr i) m;
   !i
 
 exception Found of program_info
@@ -682,7 +698,7 @@ exception Found of program_info
 let map_first m =
   try
     ProgMap.iter (fun _ v ->
-		  if snd (Ephemeron.get v).prg_obligations > 0 then
+		  if snd (CEphemeron.get v).prg_obligations > 0 then
 		    raise (Found v)) m;
     assert(false)
   with Found x -> x
@@ -698,11 +714,13 @@ let get_prog name =
 	     match n with
 		 0 -> raise (NoObligations None)
 	       | 1 -> get_info (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 progs = Id.Set.elements (ProgMap.domain prg_infos) in
+                let prog = List.hd progs in
+                let progs = prlist_with_sep pr_comma Nameops.pr_id progs in
+                errorlabstrm ""
+                  (str "More than one program with unsolved obligations: " ++ progs
+                  ++ str "; use the \"of\" clause to specify, as in \"Obligation 1 of " ++ Nameops.pr_id prog ++ str "\""))
 
 let get_any_prog () =
   let prg_infos = !from_prg in
@@ -729,11 +747,11 @@ type progress =
 let obligations_message rem =
   if rem > 0 then
     if Int.equal rem 1 then
-      Flags.if_verbose msg_info (int rem ++ str " obligation remaining")
+      Flags.if_verbose Feedback.msg_info (int rem ++ str " obligation remaining")
     else
-      Flags.if_verbose msg_info (int rem ++ str " obligations remaining")
+      Flags.if_verbose Feedback.msg_info (int rem ++ str " obligations remaining")
   else
-    Flags.if_verbose msg_info (str "No more obligations remaining")
+    Flags.if_verbose Feedback.msg_info (str "No more obligations remaining")
 
 let update_obls prg obls rem =
   let prg' = { prg with prg_obligations = (obls, rem) } in
@@ -807,14 +825,64 @@ let solve_by_tac name evi t poly ctx =
   Inductiveops.control_only_guard (Global.env ()) (fst body);
   (fst body), entry.const_entry_type, Evd.evar_universe_context ctx'
 
+let obligation_terminator name num guard hook auto pf =
+  let open Proof_global in
+  let term = Lemmas.universe_proof_terminator guard hook in
+  match pf with
+  | Admitted _ -> apply_terminator term pf
+  | Proved (opq, id, proof) ->
+    if not !shrink_obligations then apply_terminator term pf
+    else
+      let (_, (entry, uctx, _)) = Pfedit.cook_this_proof proof in
+      let env = Global.env () in
+      let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in
+      let ty = entry.Entries.const_entry_type in
+      let (body, cstr), eff = Future.force entry.Entries.const_entry_body in
+      assert(Safe_typing.empty_private_constants = eff);
+      let sigma = Evd.from_ctx (fst uctx) in
+      let sigma = Evd.merge_context_set ~sideff:true Evd.univ_rigid sigma cstr in
+      Inductiveops.control_only_guard (Global.env ()) body;
+      (** Declare the obligation ourselves and drop the hook *)
+      let prg = get_info (ProgMap.find name !from_prg) in
+      let ctx = Evd.evar_universe_context sigma in
+      let prg = { prg with prg_ctx = ctx } in
+      let obls, rem = prg.prg_obligations in
+      let obl = obls.(num) in
+      let status =
+        match obl.obl_status, opq with
+        | (_, Evar_kinds.Expand), Vernacexpr.Opaque _ -> err_not_transp ()
+        | (true, _), Vernacexpr.Opaque _ -> err_not_transp ()
+        | (false, _), Vernacexpr.Opaque _ -> Evar_kinds.Define true
+        | (_, Evar_kinds.Define true), Vernacexpr.Transparent -> Evar_kinds.Define false
+        | (_, status), Vernacexpr.Transparent -> status
+      in
+      let obl = { obl with obl_status = false, status } in
+      let uctx = Evd.evar_context_universe_context ctx in
+      let (_, obl) = declare_obligation prg obl body ty uctx in
+      let obls = Array.copy obls in
+      let _ = obls.(num) <- obl in
+      try
+      ignore (update_obls prg obls (pred rem));
+      if pred rem > 0 then
+        begin
+	  let deps = dependencies obls num in
+	  if not (Int.Set.is_empty deps) then
+	    ignore (auto (Some name) None deps)
+	end
+      with e when CErrors.noncritical e ->
+        let e = CErrors.push e in
+        pperror (CErrors.iprint (ExplainErr.process_vernac_interp_error e))
+
 let obligation_hook prg obl num auto ctx' _ gr =
   let obls, rem = prg.prg_obligations in
   let cst = match gr with ConstRef cst -> cst | _ -> assert false in
   let transparent = evaluable_constant cst (Global.env ()) in
   let () = match obl.obl_status with
-  | Evar_kinds.Expand -> if not transparent then err_not_transp ()
-  | Evar_kinds.Define op -> if not op && not transparent then err_not_transp ()
-  in
+      (true, Evar_kinds.Expand) 
+    | (true, Evar_kinds.Define true) ->
+       if not transparent then err_not_transp ()
+    | _ -> ()
+in
   let obl = { obl with obl_body = Some (DefinedObl cst) } in
   let () = if transparent then add_hint true prg cst in
   let obls = Array.copy obls in
@@ -832,9 +900,9 @@ let obligation_hook prg obl num auto ctx' _ gr =
   let prg = { prg with prg_ctx = ctx' } in
   let () =
     try ignore (update_obls prg obls (pred rem))
-    with e when Errors.noncritical e ->
-      let e = Errors.push e in
-      pperror (Errors.iprint (Cerrors.process_vernac_interp_error e))
+    with e when CErrors.noncritical e ->
+      let e = CErrors.push e in
+      pperror (CErrors.iprint (ExplainErr.process_vernac_interp_error e))
   in
   if pred rem > 0 then begin
     let deps = dependencies obls num in
@@ -855,15 +923,16 @@ let rec solve_obligation prg num tac =
         ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) remaining));
   in
   let obl = subst_deps_obl obls obl in
-  let kind = kind_of_obligation (pi2 prg.prg_kind) obl.obl_status in
+  let kind = kind_of_obligation (pi2 prg.prg_kind) (snd obl.obl_status) in
   let evd = Evd.from_ctx prg.prg_ctx in
   let evd = Evd.update_sigma_env evd (Global.env ()) in
   let auto n tac oblset = auto_solve_obligations n ~oblset tac in
+  let terminator guard hook =
+    Proof_global.make_terminator
+      (obligation_terminator prg.prg_name num guard hook auto) in
   let hook ctx = Lemmas.mk_hook (obligation_hook prg obl num auto ctx) in
-  let () = Lemmas.start_proof_univs ~sign:prg.prg_sign obl.obl_name kind evd obl.obl_type hook in
-  let () = trace (str "Started obligation " ++ int user_num ++ str "  proof: " ++
-            Printer.pr_constr_env (Global.env ()) Evd.empty obl.obl_type) in
-  let _ = Pfedit.by (snd (get_default_tactic ())) in
+  let () = Lemmas.start_proof_univs ~sign:prg.prg_sign obl.obl_name kind evd obl.obl_type ~terminator hook in
+  let _ = Pfedit.by !default_tactic in
   Option.iter (fun tac -> Pfedit.set_end_tac tac) tac
 
 and obligation (user_num, name, typ) tac =
@@ -881,7 +950,7 @@ and obligation (user_num, name, typ) tac =
 and solve_obligation_by_tac prg obls i tac =
   let obl = obls.(i) in
     match obl.obl_body with
-    | Some _ -> false
+    | Some _ -> None
     | None ->
 	try
 	  if List.is_empty (deps_remaining obls obl.obl_deps) then
@@ -892,32 +961,32 @@ and solve_obligation_by_tac prg obls i tac =
 	      | None ->
 		  match obl.obl_tac with
 		  | Some t -> t
-		  | None -> snd (get_default_tactic ())
+		  | None -> !default_tactic
 	    in
-	    let evd = Evd.from_ctx !prg.prg_ctx in
+	    let evd = Evd.from_ctx prg.prg_ctx in
 	    let evd = Evd.update_sigma_env evd (Global.env ()) in
-	    let t, ty, ctx = 
-	      solve_by_tac obl.obl_name (evar_of_obligation obl) tac 
-	        (pi2 !prg.prg_kind) (Evd.evar_universe_context evd)
+	    let t, ty, ctx =
+	      solve_by_tac obl.obl_name (evar_of_obligation obl) tac
+	        (pi2 prg.prg_kind) (Evd.evar_universe_context evd)
 	    in
 	    let uctx = Evd.evar_context_universe_context ctx in
-	    let () = prg := {!prg with prg_ctx = ctx} in
-	    let def, obl' = declare_obligation !prg obl t ty uctx in
+	    let prg = {prg with prg_ctx = ctx} in
+	    let def, obl' = declare_obligation prg obl t ty uctx in
 	      obls.(i) <- obl';
-	      if def && not (pi2 !prg.prg_kind) then (
+	      if def && not (pi2 prg.prg_kind) then (
 	        (* Declare the term constraints with the first obligation only *)
 	        let evd = Evd.from_env (Global.env ()) in
 	        let evd = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx)) in
 		let ctx' = Evd.evar_universe_context evd in
-		  prg := {!prg with prg_ctx = ctx'});
-	      true
-	  else false
-	with e when Errors.noncritical e ->
-          let (e, _) = Errors.push e in
+		  Some {prg with prg_ctx = ctx'})
+	      else Some prg
+	  else None
+	with e when CErrors.noncritical e ->
+          let (e, _) = CErrors.push e in
           match e with
 	  | Refiner.FailError (_, s) ->
 	      user_err_loc (fst obl.obl_location, "solve_obligation", Lazy.force s)
-          | e -> false
+          | e -> None (* FIXME really ? *)
 
 and solve_prg_obligations prg ?oblset tac =
   let obls, rem = prg.prg_obligations in
@@ -929,16 +998,20 @@ and solve_prg_obligations prg ?oblset tac =
     | Some s -> set := s;
       (fun i -> Int.Set.mem i !set)
   in
-  let prg = ref prg in
+  let prgref = 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))
+      if p i then
+        match solve_obligation_by_tac !prgref obls' i tac with
+	| None -> ()
+ 	| Some prg' ->
+	   prgref := prg';
+	   let deps = dependencies obls i in
+ 	   (set := Int.Set.union !set deps;
+ 	    decr rem))
       obls'
   in
-    update_obls !prg obls' !rem
+    update_obls !prgref obls' !rem
 
 and solve_obligations n tac =
   let prg = get_prog_err n in
@@ -951,15 +1024,15 @@ 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));
+    match solve_obligation_by_tac prg obls' n tac with
+    | Some prg' -> ignore(update_obls prg' obls' (pred rem))
+    | None -> ()
 
 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...");
+  Flags.if_verbose Feedback.msg_info (str "Solving obligations automatically...");
   try solve_prg_obligations (get_prog_err n) ?oblset tac with NoObligations _ -> Dependent
 
 open Pp
@@ -967,14 +1040,15 @@ 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: ");
+    if msg then Feedback.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 () ++
+		         decr showed;
+			 let x = subst_deps_obl obls x in
+			 Feedback.msg_info (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++
+				   str "of" ++ spc() ++ Id.print n ++ str ":" ++ spc () ++
 				   hov 1 (Printer.pr_constr_env (Global.env ()) Evd.empty x.obl_type ++
 					    str "." ++ fnl ())))
 		   | Some _ -> ())
@@ -991,38 +1065,38 @@ let show_obligations ?(msg=true) n =
 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 () ++
+    (Id.print 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
+let add_definition n ?term t ctx ?pl ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic
     ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) obls =
   let sign = Decls.initialize_named_context_for_proof () in
-  let info = str (Id.to_string n) ++ str " has type-checked" in
-  let prg = init_prog_info sign ~opaque n term t ctx [] None [] obls implicits kind reduce hook in
+  let info = Id.print n ++ str " has type-checked" in
+  let prg = init_prog_info sign ~opaque n pl 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 ".");
+    Flags.if_verbose Feedback.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 (Ephemeron.create prg);
+    let _ = Flags.if_verbose Feedback.msg_info (info ++ str ", generating " ++ int len ++ str " obligation(s)") in
+      progmap_add n (CEphemeron.create 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)
+let add_mutual_definitions l ctx ?pl ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce)
     ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) notations fixkind =
   let sign = Decls.initialize_named_context_for_proof () in
   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 sign ~opaque n (Some b) t ctx deps (Some fixkind)
+     let prg = init_prog_info sign ~opaque n pl (Some b) t ctx deps (Some fixkind)
        notations obls imps kind reduce hook 
-     in progmap_add n (Ephemeron.create prg)) l;
+     in progmap_add n (CEphemeron.create prg)) l;
     let _defined =
       List.fold_left (fun finished x ->
 	if finished then finished
diff --git a/toplevel/obligations.mli b/toplevel/obligations.mli
index b2320a57..69d20696 100644
--- a/toplevel/obligations.mli
+++ b/toplevel/obligations.mli
@@ -33,7 +33,8 @@ val sort_dependencies : (Evar.t * evar_info * Evar.Set.t) list -> (Evar.t * evar
    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 *
+  (Id.t * types * Evar_kinds.t Loc.located *
+     (bool * 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,
@@ -46,7 +47,7 @@ val eterm_obligations : env -> Id.t -> evar_map -> int ->
 
 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
+      (bool * 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 *)
 
@@ -54,16 +55,12 @@ 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 default_tactic : unit Proofview.tactic ref
 
 val add_definition : Names.Id.t -> ?term:Term.constr -> Term.types -> 
   Evd.evar_universe_context ->
+  ?pl:(Id.t Loc.located list) -> (* Universe binders *)
   ?implicits:(Constrexpr.explicitation * (bool * bool * bool)) list ->
   ?kind:Decl_kinds.definition_kind ->
   ?tactic:unit Proofview.tactic ->
@@ -81,6 +78,7 @@ val add_mutual_definitions :
   (Names.Id.t * Term.constr * Term.types *
       (Constrexpr.explicitation * (bool * bool * bool)) list * obligation_info) list ->
   Evd.evar_universe_context ->
+  ?pl:(Id.t Loc.located list) -> (* Universe binders *)
   ?tactic:unit Proofview.tactic ->
   ?kind:Decl_kinds.definition_kind ->
   ?reduce:(Term.constr -> Term.constr) ->
diff --git a/toplevel/record.ml b/toplevel/record.ml
index 04da628c..ef09f6fa 100644
--- a/toplevel/record.ml
+++ b/toplevel/record.ml
@@ -7,13 +7,12 @@
 (************************************************************************)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Names
 open Globnames
 open Nameops
 open Term
-open Context
 open Vars
 open Environ
 open Declarations
@@ -25,6 +24,8 @@ open Type_errors
 open Constrexpr
 open Constrexpr_ops
 open Goptions
+open Sigma.Notations
+open Context.Rel.Declaration
 
 (********** definition d'un record (structure) **************)
 
@@ -69,16 +70,19 @@ let interp_fields_evars env evars impls_env nots l =
 	| Anonymous -> impls
 	| Name id -> Id.Map.add id (compute_internalization_data env Constrintern.Method t' impl) impls
       in
-      let d = (i,b',t') in
+      let d = match b' with
+	      | None -> LocalAssum (i,t')
+	      | Some b' -> LocalDef (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) ->
+  List.fold_right (fun d (env, univ) ->
     let univ = 
-      if b = None then 
-	let s = Retyping.get_sort_of env evars t in
+      if is_local_assum d then
+	let s = Retyping.get_sort_of env evars (get_type d) in
 	  Univ.sup (univ_of_sort s) univ 
       else univ
     in (push_rel d env, univ)) 
@@ -103,27 +107,33 @@ let typecheck_params_and_fields def id pl t ps nots fs =
     in
       List.iter 
 	(function LocalRawDef (b, _) -> error default_binder_kind b
-	   | LocalRawAssum (ls, bk, ce) -> List.iter (error bk) ls) ps
+	   | LocalRawAssum (ls, bk, ce) -> List.iter (error bk) ls
+           | LocalPattern _ -> assert false) ps
   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 poly =
+         match t with
+         | CSort (_, Misctypes.GType []) -> true | _ -> false in
        let s = interp_type_evars env evars ~impls:empty_internalization_env t in
-       let sred = Reductionops.whd_betadeltaiota env !evars s in
+       let sred = Reductionops.whd_all 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)
+	    (if poly then
+               match Evd.is_sort_variable !evars s' with
+	       | Some l -> evars := Evd.make_flexible_variable !evars true l; 
+	                  sred, true
+	       | None -> s, false
+             else 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
+      let uvarkind = Evd.univ_flexible_alg in
+	mkSort (Evarutil.evd_comb0 (Evd.new_sort_variable uvarkind) evars), true
   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 env_ar = push_rel_context newps (push_rel (LocalAssum (Name id,fullarity)) env0) in
   let env2,impls,newfs,data =
     interp_fields_evars env_ar evars impls_env nots (binders_of_decls fs)
   in
@@ -135,43 +145,51 @@ let typecheck_params_and_fields def id pl t ps nots fs =
     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 && is_impredicative_set env0) then
+      if not def && (Sorts.is_prop aritysort || 
+	(Sorts.is_set aritysort && is_impredicative_set env0)) then
 	arity, evars
       else
 	let evars = Evd.set_leq_sort env_ar evars (Type univ) aritysort in
-	  if Univ.is_small_univ univ then
-	    (* We can assume that the level aritysort is not constrained
-  	       and clear it. *)
-	    mkArity (ctx, Sorts.sort_of_univ univ),
-	    Evd.set_eq_sort env_ar evars (Prop Pos) aritysort
-	  else arity, evars
+	if Univ.is_small_univ univ &&
+	   Option.cata (Evd.is_flexible_level evars) false (Evd.is_sort_variable evars aritysort) then
+	   (* We can assume that the level in aritysort is not constrained
+	       and clear it, if it is flexible *)
+	  mkArity (ctx, Sorts.sort_of_univ univ),
+	  Evd.set_eq_sort env_ar evars (Prop Pos) aritysort
+	else arity, evars
   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);
+  let newps = Context.Rel.map nf newps in
+  let newfs = Context.Rel.map nf newfs in
+  let ce t = Pretyping.check_evars env0 Evd.empty evars t in
+    List.iter (iter_constr ce) (List.rev newps);
+    List.iter (iter_constr ce) (List.rev newfs);
     Evd.universe_context ?names:pl evars, nf arity, template, imps, newps, impls, newfs
 
-let degenerate_decl (na,b,t) =
-  let id = match na with
+let degenerate_decl decl =
+  let id = match get_name decl with
     | Name id -> id
     | Anonymous -> anomaly (Pp.str "Unnamed record variable") in
-  match b with
-    | None -> (id, LocalAssum t)
-    | Some b -> (id, LocalDef b)
+  match decl with
+    | LocalAssum (_,t) -> (id, LocalAssumEntry t)
+    | LocalDef (_,b,_) -> (id, LocalDefEntry b)
 
 type record_error =
   | MissingProj of Id.t * Id.t list
   | BadTypedProj of Id.t * env * Type_errors.type_error
 
+let warn_cannot_define_projection =
+  CWarnings.create ~name:"cannot-define-projection" ~category:"records"
+         (fun msg -> hov 0 msg)
+
+(* If a projection is not definable, we throw an error if the user
+asked it to be a coercion. Otherwise, we just print an info
+message. The user might still want to name the field of the record. *)
 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(Id.to_string fi) ++
+        (pr_id 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.")
@@ -191,7 +209,7 @@ 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 msg_warning (hov 0 st)
+  Flags.if_verbose Feedback.msg_info (hov 0 st)
 
 type field_status =
   | NoProjection of Name.t
@@ -234,6 +252,12 @@ 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
 
+let warn_non_primitive_record =
+  CWarnings.create ~name:"non-primitive-record" ~category:"record"
+         (fun (env,indsp) ->
+          (hov 0 (str "The record " ++ Printer.pr_inductive env indsp ++ 
+                    strbrk" could not be defined as a primitive record")))
+
 (* We build projections *)
 let declare_projections indsp ?(kind=StructureComponent) binder_name coers fieldimpls fields =
   let env = Global.env() in
@@ -244,8 +268,8 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field
   let 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 rp = applist (r, Context.Rel.to_extended_list 0 paramdecls) in
+  let paramargs = Context.Rel.to_extended_list 1 paramdecls in (*def in [[params;x:rp]]*)
   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
@@ -257,31 +281,31 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field
 	| 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"));
+	  warn_non_primitive_record (env,indsp);
 	is_primitive
     else false
   in
   let (_,_,kinds,sp_projs,_) =
     List.fold_left3
-      (fun (nfi,i,kinds,sp_projs,subst) coe (fi,optci,ti) impls ->
+      (fun (nfi,i,kinds,sp_projs,subst) coe decl impls ->
+        let fi = get_name decl in
+        let ti = get_type decl in
 	let (sp_projs,i,subst) =
 	  match fi with
 	  | Anonymous ->
 	      (None::sp_projs,i,NoProjection fi::subst)
 	  | Name fid -> try
 	    let kn, term = 
-	      if optci = None && primitive then 
+	      if is_local_assum decl && 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 ->
+		let body = match decl with
+		  | LocalDef (_,ci,_) -> subst_projection fid subst ci
+		  | LocalAssum _ ->
 	            (* [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
@@ -323,28 +347,32 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field
 	      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
+	    let i = if is_local_assum decl 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,i,NoProjection fi::subst) in
-      (nfi-1,i,(fi, Option.is_empty optci)::kinds,sp_projs,subst))
+      (nfi-1,i,(fi, is_local_assum decl)::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)] ->
+      | [decl] ->
         let env = Environ.empty_named_context_val in
-        let (evm, _) = Evarutil.new_pure_evar env evm typ in
+        let evm = Sigma.Unsafe.of_evar_map evm in
+        let Sigma (_, evm, _) = Evarutil.new_pure_evar env evm (get_type decl) in
+        let evm = Sigma.to_evar_map evm in
         evm
-      | (_,_,typ)::tl ->
+      | decl::tl ->
           let env = Environ.empty_named_context_val in
-          let (evm, ev) = Evarutil.new_pure_evar env evm typ in
+          let evm = Sigma.Unsafe.of_evar_map evm in
+          let Sigma (ev, evm, _) = Evarutil.new_pure_evar env evm (get_type decl) in
+          let evm = Sigma.to_evar_map evm 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
+	    (fun pos decl ->
+	       map_type (fun t -> Termops.replace_term (mkRel pos) (mkEvar(ev,[||])) t) decl) 1 tl in
 	  deps_to_evar evm new_tl in
   deps_to_evar Evd.empty (List.rev ctx)
 
@@ -353,7 +381,7 @@ open Typeclasses
 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 args = Context.Rel.to_extended_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 = 
@@ -375,7 +403,9 @@ let declare_structure finite poly ctx id idbuild paramimpls params arity templat
       mind_entry_inds = [mie_ind];
       mind_entry_polymorphic = poly;
       mind_entry_private = None;
-      mind_entry_universes = ctx } in
+      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
@@ -392,7 +422,7 @@ let implicits_of_context ctx =
       | Name n -> Some n
       | Anonymous -> None
     in ExplByPos (i, explname), (true, true, true))
-    1 (List.rev (Anonymous :: (List.map pi1 ctx)))
+    1 (List.rev (Anonymous :: (List.map get_name ctx)))
 
 let declare_class finite def poly ctx id idbuild paramimpls params arity 
     template fieldimpls fields ?(kind=StructureComponent) is_coe coers priorities sign =
@@ -405,11 +435,11 @@ let declare_class finite def poly ctx id idbuild paramimpls params arity
   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 ->
+    | [LocalAssum (Name proj_name, field) | LocalDef (Name proj_name, _, field)] when def ->
       let class_body = it_mkLambda_or_LetIn field params in
-      let _class_type = it_mkProd_or_LetIn arity params 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
+	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
@@ -446,13 +476,13 @@ let declare_class finite def poly ctx id idbuild paramimpls params arity
 			      if b then Backward, pri else Forward, pri) coe)
 	  coers priorities
        in
-       let l = List.map3 (fun (id, _, _) b y -> (id, b, y))
+       let l = List.map3 (fun decl b y -> get_name decl, b, y)
          (List.rev fields) coers (Recordops.lookup_projections ind)
        in IndRef ind, l
   in
   let ctx_context =
-    List.map (fun (na, b, t) ->
-      match Typeclasses.class_of_constr t with
+    List.map (fun decl ->
+      match Typeclasses.class_of_constr (get_type decl) with
       | Some (_, ((cl,_), _)) -> Some (cl.cl_impl, true)
       | None -> None)
       params, params
@@ -474,7 +504,7 @@ let add_constant_class cst =
   let tc = 
     { cl_impl = ConstRef cst;
       cl_context = (List.map (const None) ctx, ctx);
-      cl_props = [(Anonymous, None, arity)];
+      cl_props = [LocalAssum (Anonymous, arity)];
       cl_projs = [];
       cl_strict = !typeclasses_strict;
       cl_unique = !typeclasses_unique
@@ -487,19 +517,13 @@ let add_inductive_class ind =
   let k =
     let ctx = oneind.mind_arity_ctxt in
     let inst = Univ.UContext.instance mind.mind_universes in
-    let map = function
-    | (_, Some _, _) -> None
-    | (_, None, t) -> Some (lazy t)
-    in
-    let args = List.map_filter map ctx in
-    let ty = Inductive.type_of_inductive_knowing_parameters
+    let ty = Inductive.type_of_inductive
       (push_rel_context ctx (Global.env ()))
       ((mind,oneind),inst)
-      (Array.of_list args)
     in
       { cl_impl = IndRef ind;
 	cl_context = List.map (const None) ctx, ctx;
-	cl_props = [Anonymous, None, ty];
+	cl_props = [LocalAssum (Anonymous, ty)];
 	cl_projs = [];
 	cl_strict = !typeclasses_strict;
 	cl_unique = !typeclasses_unique }
@@ -516,7 +540,7 @@ open Vernacexpr
 
 (* [fs] corresponds to fields and [ps] to parameters; [coers] is a
    list telling if the corresponding fields must me declared as coercions 
-   or subinstances *)
+   or subinstances. *)
 let definition_structure (kind,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cfs,idbuild,s) =
   let cfs,notations = List.split cfs in
   let cfs,priorities = List.split cfs in
@@ -537,15 +561,16 @@ let definition_structure (kind,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cfs,id
       typecheck_params_and_fields (kind = Class true) idstruc pl s ps notations fs) () in
   let sign = structure_signature (fields@params) in
   let gr = match kind with
-    | Class def ->
-	let gr = declare_class finite def poly ctx (loc,idstruc) idbuild
+  | Class def ->
+     let priorities = List.map (fun id -> {hint_priority = id; hint_pattern = None}) priorities in
+     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 implfs = List.map
 	  (fun impls -> implpars @ Impargs.lift_implicits
 	    (succ (List.length params)) impls) implfs in
-	let ind = declare_structure finite poly ctx idstruc 
+	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 4ce27755..c50e5778 100644
--- a/toplevel/record.mli
+++ b/toplevel/record.mli
@@ -8,7 +8,6 @@
 
 open Names
 open Term
-open Context
 open Vernacexpr
 open Constrexpr
 open Impargs
@@ -22,15 +21,16 @@ val primitive_flag : bool ref
 
 val declare_projections :
   inductive -> ?kind:Decl_kinds.definition_object_kind -> Id.t ->
-  coercion_flag list -> manual_explicitation list list -> rel_context ->
+  coercion_flag list -> manual_explicitation list list -> Context.Rel.t ->
   (Name.t * bool) list * constant option list
 
-val declare_structure : Decl_kinds.recursivity_kind ->
+val declare_structure :
+  Decl_kinds.recursivity_kind ->
   bool (** polymorphic?*) -> Univ.universe_context ->
   Id.t -> Id.t ->
-  manual_explicitation list -> rel_context -> (** params *) constr -> (** arity *)
+  manual_explicitation list -> Context.Rel.t -> (** params *) constr -> (** arity *)
   bool (** template arity ? *) ->
-  Impargs.manual_explicitation list list -> rel_context -> (** fields *)
+  Impargs.manual_explicitation list list -> Context.Rel.t -> (** fields *)
   ?kind:Decl_kinds.definition_object_kind -> ?name:Id.t ->
   bool -> (** coercion? *)
   bool list -> (** field coercions *)
@@ -38,7 +38,8 @@ val declare_structure : Decl_kinds.recursivity_kind ->
   inductive
 
 val definition_structure :
-  inductive_kind * Decl_kinds.polymorphic * Decl_kinds.recursivity_kind * plident with_coercion * local_binder list *
+  inductive_kind * Decl_kinds.polymorphic * Decl_kinds.recursivity_kind *
+  plident with_coercion * local_binder list *
   (local_decl_expr with_instance with_priority with_notation) list *
   Id.t * constr_expr option -> global_reference
 
diff --git a/toplevel/search.ml b/toplevel/search.ml
index d7a4cbe7..ff3c7a4f 100644
--- a/toplevel/search.ml
+++ b/toplevel/search.ml
@@ -18,10 +18,17 @@ open Printer
 open Libnames
 open Globnames
 open Nametab
+open Goptions
 
 type filter_function = global_reference -> env -> constr -> bool
 type display_function = global_reference -> env -> constr -> unit
 
+(* This option restricts the output of [SearchPattern ...],
+[SearchAbout ...], etc. to the names of the symbols matching the
+query, separated by a newline. This type of output is useful for
+editors (like emacs), to generate a list of completion candidates
+without having to parse thorugh the types of all symbols. *)
+
 type glob_search_about_item =
   | GlobSearchSubPattern of constr_pattern
   | GlobSearchString of string
@@ -49,7 +56,9 @@ let iter_constructors indsp u fn env nconstr =
     fn (ConstructRef (indsp, i)) env typ
   done
 
-let iter_named_context_name_type f = List.iter (fun (nme,_,typ) -> f nme typ) 
+let iter_named_context_name_type f =
+  let open Context.Named.Declaration in
+  List.iter (fun decl -> f (get_id decl) (get_type decl))
 
 (* General search over hypothesis of a goal *)
 let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) =
@@ -61,12 +70,13 @@ let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) =
 
 (* General search over declarations *)
 let iter_declarations (fn : global_reference -> env -> constr -> unit) =
+  let open Context.Named.Declaration in
   let env = Global.env () in
   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
+      let decl = Global.lookup_named (basename sp) in
+      fn (VarRef (get_id decl)) env (get_type decl)
     with Not_found -> (* we are in a section *) () end
   | "CONSTANT" ->
     let cst = Global.constant_of_delta_kn kn in
@@ -97,15 +107,6 @@ let generic_search glnumopt fn =
   | Some glnum ->  iter_hypothesis glnum fn);
   iter_declarations fn
 
-(** Standard display *)
-
-let plain_display accu ref env c =
-  let pc = pr_lconstr_env env Evd.empty c in
-  let pr = pr_global ref in
-  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. *)
@@ -131,8 +132,9 @@ let full_name_of_reference ref =
   DirPath.to_string dir ^ "." ^ Id.to_string id
 
 (** Whether a reference is blacklisted *)
-let blacklist_filter ref env typ =
+let blacklist_filter_aux () =
   let l = SearchBlacklist.elements () in
+  fun ref env typ ->
   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
@@ -156,19 +158,17 @@ let search_about_filter query gr env typ = match query with
 
 (** SearchPattern *)
 
-let search_pattern gopt pat mods =
-  let ans = ref [] in
+let search_pattern gopt pat mods pr_search =
+  let blacklist_filter = blacklist_filter_aux () 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
+    module_filter mods ref env typ &&
+    pattern_filter pat ref env typ &&
+    blacklist_filter ref env typ
   in
   let iter ref env typ =
-    if filter ref env typ then plain_display ans ref env typ
+    if filter ref env typ then pr_search ref env typ
   in
-  let () = generic_search gopt iter in
-  format_display !ans
+  generic_search gopt iter
 
 (** SearchRewrite *)
 
@@ -180,63 +180,56 @@ let rewrite_pat1 pat =
 let rewrite_pat2 pat =
   PApp (PRef eq, [| PMeta None; PMeta None; pat |])
 
-let search_rewrite gopt pat mods =
+let search_rewrite gopt pat mods pr_search =
   let pat1 = rewrite_pat1 pat in
   let pat2 = rewrite_pat2 pat in
-  let ans = ref [] in
+  let blacklist_filter = blacklist_filter_aux () 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
+    module_filter mods ref env typ &&
+    (pattern_filter pat1 ref env typ ||
+       pattern_filter pat2 ref env typ) &&
+    blacklist_filter ref env typ
   in
   let iter ref env typ =
-    if filter ref env typ then plain_display ans ref env typ
+    if filter ref env typ then pr_search ref env typ
   in
-  let () = generic_search gopt iter in
-  format_display !ans
+  generic_search gopt iter
 
 (** Search *)
 
-let search_by_head gopt pat mods =
-  let ans = ref [] in
+let search_by_head gopt pat mods pr_search =
+  let blacklist_filter = blacklist_filter_aux () 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
+    module_filter mods ref env typ &&
+    head_filter pat ref env typ &&
+    blacklist_filter ref env typ
   in
   let iter ref env typ =
-    if filter ref env typ then plain_display ans ref env typ
+    if filter ref env typ then pr_search ref env typ
   in
-  let () = generic_search gopt iter in
-  format_display !ans
+  generic_search gopt iter
 
 (** SearchAbout *)
 
-let search_about gopt items mods =
-  let ans = ref [] in
+let search_about gopt items mods pr_search =
+  let blacklist_filter = blacklist_filter_aux () 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
+    module_filter mods ref env typ &&
+    List.for_all
+      (fun (b,i) -> eqb b (search_about_filter i ref env typ)) items &&
+    blacklist_filter ref env typ
   in
   let iter ref env typ =
-    if filter ref env typ then plain_display ans ref env typ
+    if filter ref env typ then pr_search ref env typ
   in
-  let () = generic_search gopt iter in
-  format_display !ans
+  generic_search gopt iter
 
 type search_constraint =
-  | Name_Pattern of string
-  | Type_Pattern of string
-  | SubType_Pattern of string
-  | In_Module of string list
+  | Name_Pattern of Str.regexp
+  | Type_Pattern of Pattern.constr_pattern
+  | SubType_Pattern of Pattern.constr_pattern
+  | In_Module of Names.DirPath.t
   | Include_Blacklist
 
 type 'a coq_object = {
@@ -245,43 +238,25 @@ type 'a coq_object = {
   coq_object_object : 'a;
 }
 
-let interface_search flags =
-  let env = Global.env () in
+let interface_search =
   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.errorlabstrm "Search.interface_search"
-          (str "Invalid regexp: " ++ str s)
-    in
+  | (Name_Pattern regexp, b) :: l ->
     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
+  | (Type_Pattern pat, b) :: l ->
     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
+  | (SubType_Pattern pat, b) :: l ->
     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.errorlabstrm "Search.interface_search"
-          (str "Module " ++ str path ++ str " not found.")
-    in
+  | (In_Module id, b) :: l ->
     extract_flags name tpe subtpe ((id, b) :: mods) blacklist l
   | (Include_Blacklist, b) :: l ->
     extract_flags name tpe subtpe mods b l
   in
+  fun ?glnum flags ->
   let (name, tpe, subtpe, mods, blacklist) =
     extract_flags [] [] [] [] false flags
   in
+  let blacklist_filter = blacklist_filter_aux () 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
@@ -300,13 +275,11 @@ let interface_search flags =
     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
+    List.for_all match_module mods &&
+    (blacklist || blacklist_filter ref env constr)
   in
   let ans = ref [] in
   let print_function ref env constr =
@@ -335,5 +308,8 @@ let interface_search flags =
   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? *)
+  let () = generic_search glnum iter in
   !ans
+
+let blacklist_filter ref env typ =
+  blacklist_filter_aux () ref env typ
diff --git a/toplevel/search.mli b/toplevel/search.mli
index 78b0c45c..ba3d48ef 100644
--- a/toplevel/search.mli
+++ b/toplevel/search.mli
@@ -39,21 +39,24 @@ val search_about_filter : glob_search_about_item -> filter_function
 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_by_head : int option -> constr_pattern -> DirPath.t list * bool
+                  -> display_function -> unit
+val search_rewrite : int option -> constr_pattern -> DirPath.t list * bool
+                  -> display_function -> unit
+val search_pattern : int option -> constr_pattern -> DirPath.t list * bool
+                  -> display_function -> unit
 val search_about   : int option -> (bool * glob_search_about_item) list
-  -> DirPath.t list * bool -> std_ppcmds
+                  -> DirPath.t list * bool -> display_function -> unit
 
 type search_constraint =
   (** Whether the name satisfies a regexp (uses Ocaml Str syntax) *)
-  | Name_Pattern of string
+  | Name_Pattern of Str.regexp
   (** Whether the object type satisfies a pattern *)
-  | Type_Pattern of string
+  | Type_Pattern of Pattern.constr_pattern
   (** Whether some subtype of object type satisfies a pattern *)
-  | SubType_Pattern of string
+  | SubType_Pattern of Pattern.constr_pattern
   (** Whether the object pertains to a module *)
-  | In_Module of string list
+  | In_Module of Names.DirPath.t
   (** Bypass the Search blacklist *)
   | Include_Blacklist
 
@@ -63,7 +66,7 @@ type 'a coq_object = {
   coq_object_object : 'a;
 }
 
-val interface_search : (search_constraint * bool) list ->
+val interface_search : ?glnum:int -> (search_constraint * bool) list ->
   string coq_object list
 
 (** {6 Generic search function} *)
diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib
index 5aa7d428..d6892236 100644
--- a/toplevel/toplevel.mllib
+++ b/toplevel/toplevel.mllib
@@ -1,5 +1,5 @@
 Himsg
-Cerrors
+ExplainErr
 Class
 Locality
 Metasyntax
diff --git a/toplevel/usage.ml b/toplevel/usage.ml
index 4280006b..38ceacf5 100644
--- a/toplevel/usage.ml
+++ b/toplevel/usage.ml
@@ -11,6 +11,10 @@ let version ret =
     Coq_config.version Coq_config.date;
   Printf.printf "compiled on %s with OCaml %s\n" Coq_config.compile_date Coq_config.caml_version;
   exit ret
+let machine_readable_version ret =
+  Printf.printf "%s %s\n"
+    Coq_config.version Coq_config.caml_version;
+  exit ret
 
 (* print the usage of coqtop (or coqc) on channel co *)
 
@@ -32,8 +36,6 @@ let print_usage_channel co command =
 \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\
 \n\
 \n  -load-ml-object f      load ML object file f\
 \n  -load-ml-source f      load ML file f\
@@ -45,6 +47,7 @@ let print_usage_channel co command =
 \n  -require path          load Coq library path and import it (Require Import path.)\
 \n  -compile f.v           compile Coq file f.v (implies -batch)\
 \n  -compile-verbose f.v   verbosely compile Coq file f.v (implies -batch)\
+\n  -o f.vo                use f.vo as the output file name\
 \n  -quick                 quickly compile .v files to .vio files (skip proofs)\
 \n  -schedule-vio2vo j f1..fn   run up to j instances of Coq to turn each fi.vio\
 \n                         into fi.vo\
@@ -56,8 +59,8 @@ let print_usage_channel co command =
 \n  -v                     print Coq version and exit\
 \n  -list-tags             print highlight color tags known by Coq and exit\
 \n\
-\n  -quiet                 unset display of extra information (implies -w none)\
-\n  -w (all|none)          configure display of warnings\
+\n  -quiet                 unset display of extra information (implies -w \"-all\")\
+\n  -w (w1,..,wn)          configure display of warnings\
 \n  -color (yes|no|auto)   configure color output\
 \n\
 \n  -q                     skip loading of rcfile\
@@ -77,6 +80,7 @@ let print_usage_channel co command =
 \n                         the directory $COQ_XML_LIBRARY_ROOT (if set) or to\
 \n                         stdout (if unset)\
 \n  -time                  display the time taken by each command\
+\n  -profile-ltac          display the time taken by each (sub)tactic\
 \n  -m, --memory           display total heap size at program exit\
 \n                         (use environment variable\
 \n                          OCAML_GC_STATS=\"/tmp/gclog.txt\"\
@@ -117,12 +121,7 @@ let print_config () =
   if Coq_config.local then Printf.printf "LOCAL=1\n" else Printf.printf "LOCAL=0\n";
   Printf.printf "COQLIB=%s/\n" (Envars.coqlib ());
   Printf.printf "DOCDIR=%s/\n" (Envars.docdir ());
-  Printf.printf "OCAMLDEP=%s\n" Coq_config.ocamldep;
-  Printf.printf "OCAMLC=%s\n" Coq_config.ocamlc;
-  Printf.printf "OCAMLOPT=%s\n" Coq_config.ocamlopt;
-  Printf.printf "OCAMLDOC=%s\n" Coq_config.ocamldoc;
-  Printf.printf "CAMLBIN=%s/\n" (Envars.camlbin ());
-  Printf.printf "CAMLLIB=%s/\n" (Envars.camllib ());
+  Printf.printf "OCAMLFIND=%s\n" (Envars.ocamlfind ());
   Printf.printf "CAMLP4=%s\n" Coq_config.camlp4;
   Printf.printf "CAMLP4O=%s\n" Coq_config.camlp4o;
   Printf.printf "CAMLP4BIN=%s/\n" (Envars.camlp4bin ());
diff --git a/toplevel/usage.mli b/toplevel/usage.mli
index 3ce9e93e..dccb40e7 100644
--- a/toplevel/usage.mli
+++ b/toplevel/usage.mli
@@ -9,6 +9,7 @@
 (** {6 Prints the version number on the standard output and exits (with 0). } *)
 
 val version : int -> 'a
+val machine_readable_version : int -> 'a
 
 (** {6 Prints the usage on the error output, preceeded by a user-provided message. } *)
 val print_usage : string -> unit
diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml
index 7c4920df..bfdae85d 100644
--- a/toplevel/vernac.ml
+++ b/toplevel/vernac.ml
@@ -9,27 +9,29 @@
 (* Parsing of vernacular. *)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Flags
-open System
 open Vernacexpr
 
 (* 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). *)
 
-(* The navigation vernac commands will be handled separately *)
+let user_error loc s = CErrors.user_err_loc (loc,"_",str s)
+
+(* Navigation commands are allowed in a coqtop session but not in a .v file *)
 
 let rec is_navigation_vernac = function
   | VernacResetInitial
   | VernacResetName _
   | VernacBacktrack _
   | VernacBackTo _
-  | VernacBack _ -> true
-  | VernacRedirect (_, l) | VernacTime l ->
-    List.exists
-      (fun (_,c) -> is_navigation_vernac c) l (* Time Back* is harmless *)
+  | VernacBack _
+  | VernacStm _ -> true
+  | VernacRedirect (_, (_,c))
+  | VernacTime (_,c) ->
+      is_navigation_vernac c (* Time Back* is harmless *)
   | c -> is_deep_navigation_vernac c
 
 and is_deep_navigation_vernac = function
@@ -42,6 +44,14 @@ let is_reset = function
   | VernacResetInitial | VernacResetName _ -> true
   | _ -> false
 
+let checknav_simple loc cmd =
+  if is_navigation_vernac cmd && not (is_reset cmd) then
+    user_error loc "Navigation commands forbidden in files."
+
+let checknav_deep loc ast =
+  if is_deep_navigation_vernac ast then
+    user_error loc "Navigation commands forbidden in nested commands."
+
 (* When doing Load on a file, two behaviors are possible:
 
    - either the history stack is grown by only one command,
@@ -66,32 +76,10 @@ let _ =
       Goptions.optread  = (fun () -> !atomic_load);
       Goptions.optwrite = ((:=) atomic_load) }
 
-(* 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. *)
-
-type location_files = { outer : string; inner : string }
-
-let files_of_exn : location_files Exninfo.t = Exninfo.make ()
-
-let get_exn_files e = Exninfo.get e files_of_exn
-
-let add_exn_files e f = Exninfo.add e files_of_exn f
-
-let enrich_with_file f (e, info) =
-  let inner = match get_exn_files info with None -> f | Some x -> x.inner in
-  (e, add_exn_files info { outer = f; inner })
-
-let raise_with_file f e = iraise (enrich_with_file f e)
-
-let cur_file = ref None
-
 let disable_drop = function
-  | Drop -> Errors.error "Drop is forbidden."
+  | Drop -> CErrors.error "Drop is forbidden."
   | e -> e
 
-let user_error loc s = Errors.user_err_loc (loc,"_",str s)
-
 (* Opening and closing a channel. Open it twice when verbose: the first
    channel is used to read the commands, and the second one to print them.
    Note: we could use only one thanks to seek_in, but seeking on and on in
@@ -101,7 +89,7 @@ let open_file_twice_if verbosely longfname =
   let in_chan = open_utf8_file_in longfname in
   let verb_ch =
     if verbosely then Some (open_utf8_file_in longfname) else None in
-  let po = Pcoq.Gram.parsable (Stream.of_channel in_chan) in
+  let po = Pcoq.Gram.parsable ~file:longfname (Stream.of_channel in_chan) in
   (in_chan, longfname, (po, verb_ch))
 
 let close_input in_chan (_,verb) =
@@ -110,7 +98,7 @@ let close_input in_chan (_,verb) =
     match verb with
       | Some verb_ch -> close_in verb_ch
       | _ -> ()
-  with e when Errors.noncritical e -> ()
+  with e when CErrors.noncritical e -> ()
 
 let verbose_phrase verbch loc =
   let loc = Loc.unloc loc in
@@ -120,8 +108,7 @@ let verbose_phrase verbch loc =
 	let s = String.create len in
         seek_in ch (fst loc);
         really_input ch s 0 len;
-        ppnl (str s);
-        pp_flush()
+        Feedback.msg_notice (str s)
     | None -> ()
 
 exception End_of_input
@@ -135,51 +122,44 @@ let parse_sentence = Flags.with_option Flags.we_are_parsing
 (* vernac parses the given stream, executes interpfun on the syntax tree it
  * parses, and is verbose on "primitives" commands if verbosely is true *)
 
-let just_parsing = ref false
 let chan_beautify = ref stdout
 let beautify_suffix = ".beautified"
 
-let set_formatter_translator() =
-  let ch = !chan_beautify in
+let set_formatter_translator ch =
   let out s b e = output ch s b e in
   Format.set_formatter_output_functions out (fun () -> flush ch);
   Format.set_max_boxes max_int
 
-let pr_new_syntax loc ocom =
+let pr_new_syntax_in_context loc chan_beautify ocom =
   let loc = Loc.unloc loc in
-  if !beautify_file then set_formatter_translator();
+  if !beautify_file then set_formatter_translator chan_beautify;
   let fs = States.freeze ~marshallable:`No in
-  let com = match ocom with
-    | Some VernacNop -> mt()
-    | Some com -> Ppvernac.pr_vernac com
-    | None -> mt() in
-  if !beautify_file then
-    msg (hov 0 (comment (fst loc) ++ com ++ comment (snd loc)))
-  else
-    msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com)));
-  States.unfreeze fs;
-  Format.set_formatter_out_channel stdout
-
-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
+  (* The content of this is not supposed to fail, but if ever *)
+  try
+    (* Side-effect: order matters *)
+    let before = comment (CLexer.extract_comments (fst loc)) in
+    let com = match ocom with
+      | Some com -> Ppvernac.pr_vernac com
+      | None -> mt() in
+    let after = comment (CLexer.extract_comments (snd loc)) in
+    if !beautify_file then
+      Pp.msg_with !Pp_control.std_ft (hov 0 (before ++ com ++ after))
+    else
+      Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com)));
+    States.unfreeze fs;
+    Format.set_formatter_out_channel stdout
+  with any ->
+    States.unfreeze fs;
+    Format.set_formatter_out_channel stdout
+
+let pr_new_syntax po loc chan_beautify ocom =
+  (* Reinstall the context of parsing which includes the bindings of comments to locations *)
+  Pcoq.Gram.with_parsable po (pr_new_syntax_in_context chan_beautify loc) ocom
 
 (* For coqtop -time, we display the position in the file,
    and a glimpse of the executed command *)
 
-let display_cmd_header loc com =
+let pp_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
@@ -194,75 +174,63 @@ let display_cmd_header loc com =
     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 " [" ++ str cmd ++ str "] ");
-  Pp.flush_all ()
+  in str "Chars " ++ int start ++ str " - " ++ int stop ++
+     str " [" ++ str cmd ++ str "] "
 
-let rec vernac_com verbose checknav (loc,com) =
+(* This is a special case where we assume we are in console batch mode
+   and take control of the console.
+ *)
+let print_cmd_header loc com =
+  Pp.pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft (pp_cmd_header loc com);
+  Format.pp_print_flush !Pp_control.std_ft ()
+
+let rec interp_vernac po chan_beautify 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 fname = Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in
         let fname = CUnix.make_suffix fname ".v" in
         let f = Loadpath.locate_file fname in
-	let st = save_translator_coqdoc () in
-	if !Flags.beautify_file then
-	  begin
-	    chan_beautify := open_out (f^beautify_suffix);
-	    Pp.comments := []
-          end;
-	begin
-	  try
-            read_vernac_file verbosely f;
-	    restore_translator_coqdoc st;
-	  with reraise ->
-            let reraise = Errors.push reraise in
-	    restore_translator_coqdoc st;
-	    iraise reraise
-	end
-
-    | v when !just_parsing -> ()
-
-    | v -> Stm.interp verbose (loc,v)
+        load_vernac verbosely f
+
+    | v -> Stm.interp (Flags.is_verbose()) (loc,v)
   in
     try
       checknav loc com;
-      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
+      if !beautify then pr_new_syntax po chan_beautify loc (Some com);
+      (* XXX: This is not 100% correct if called from an IDE context *)
+      if !Flags.time then print_cmd_header loc com;
+      let com = if !Flags.time then VernacTime (loc,com) else com in
       interp com
     with reraise ->
-      let (reraise, info) = Errors.push reraise in
-      Format.set_formatter_out_channel stdout;
+      let (reraise, info) = CErrors.push reraise in
       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 =
-  let checknav loc cmd =
-    if is_navigation_vernac cmd && not (is_reset cmd) then
-	user_error loc "Navigation commands forbidden in files"
-  in
-  let (in_chan, fname, input) = open_file_twice_if verbosely s in
-  cur_file := Some fname;
+(* Load a vernac file. CErrors are annotated with file and location *)
+and load_vernac verbosely file =
+  let chan_beautify =
+    if !Flags.beautify_file then open_out (file^beautify_suffix) else stdout in
+  let (in_chan, fname, input) = open_file_twice_if verbosely file in
   try
     (* we go out of the following infinite loop when a End_of_input is
      * 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 verbosely checknav loc_ast;
-      pp_flush ()
+      let loc_ast = Flags.silently parse_sentence input in
+      CWarnings.set_current_loc (fst loc_ast);
+      Flags.silently (interp_vernac (fst input) chan_beautify checknav_simple) loc_ast;
     done
   with any ->   (* whatever the exception *)
-    let (e, info) = Errors.push any in
-    Format.set_formatter_out_channel stdout;
+    let (e, info) = CErrors.push any in
     close_input in_chan input;    (* we must close the file first *)
     match e with
       | End_of_input ->
-          cur_file := None;
-          if do_beautify () then
-            pr_new_syntax (Loc.make_loc (max_int,max_int)) None
-      | _ -> raise_with_file fname (disable_drop e, info)
+          if !beautify then
+            pr_new_syntax (fst input) chan_beautify (Loc.make_loc (max_int,max_int)) None;
+          if !Flags.beautify_file then close_out chan_beautify;
+      | reraise ->
+         if !Flags.beautify_file then close_out chan_beautify;
+	 iraise (disable_drop e, info)
 
 (** [eval_expr : ?preserving:bool -> Loc.t * Vernacexpr.vernac_expr -> unit]
    It executes one vernacular command. By default the command is
@@ -271,34 +239,50 @@ and read_vernac_file verbosely s =
    of a new state label). An example of state-preserving command is one coming
    from the query panel of Coqide. *)
 
-let checknav loc ast =
-  if is_deep_navigation_vernac ast then
-    user_error loc "Navigation commands forbidden in nested commands"
-
-let eval_expr loc_ast = vernac_com (Flags.is_verbose()) checknav loc_ast
+let process_expr po loc_ast = interp_vernac po stdout checknav_deep loc_ast
 
 (* XML output hooks *)
 let (f_xml_start_library, xml_start_library) = Hook.make ~default:ignore ()
 let (f_xml_end_library, xml_end_library) = Hook.make ~default:ignore ()
 
-(* 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
-    Flags.silently (read_vernac_file verb) file;
-    if !Flags.beautify_file then close_out !chan_beautify;
-  with any ->
-    let (e, info) = Errors.push any in
-    if !Flags.beautify_file then close_out !chan_beautify;
-    raise_with_file file (disable_drop e, info)
+let warn_file_no_extension =
+  CWarnings.create ~name:"file-no-extension" ~category:"filesystem"
+         (fun (f,ext) ->
+          str "File \"" ++ str f ++
+            strbrk "\" has been implicitly expanded to \"" ++
+            str f ++ str ext ++ str "\"")
 
-let ensure_v f =
-  if Filename.check_suffix f ".v" then f
+let ensure_ext ext f =
+  if Filename.check_suffix f ext then f
   else begin
-    msg_warning (str "File \"" ++ str f ++ strbrk "\" has been implicitly \
-    expanded to \"" ++ str f ++ str ".v\"");
-    f ^ ".v"
+    warn_file_no_extension (f,ext);
+    f ^ ext
+  end
+
+let chop_extension f =
+  try Filename.chop_extension f with _ -> f
+
+let ensure_bname src tgt =
+  let src, tgt = Filename.basename src, Filename.basename tgt in
+  let src, tgt = chop_extension src, chop_extension tgt in
+  if src <> tgt then begin
+    Feedback.msg_error (str "Source and target file names must coincide, directories can differ");
+    Feedback.msg_error (str "Source: " ++ str src);
+    Feedback.msg_error (str "Target: " ++ str tgt);
+    flush_all ();
+    exit 1
+  end
+
+let ensure ext src tgt = ensure_bname src tgt; ensure_ext ext tgt
+
+let ensure_v v = ensure ".v" v v
+let ensure_vo v vo = ensure ".vo" v vo
+let ensure_vio v vio = ensure ".vio" v vio
+
+let ensure_exists f =
+  if not (Sys.file_exists f) then begin
+    Feedback.msg_error (hov 0 (str "Can't find file" ++ spc () ++ str f));
+    exit 1
   end
 
 (* Compile a vernac file *)
@@ -306,14 +290,21 @@ let compile verbosely f =
   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
+      (Feedback.msg_error (str "There are pending proofs"); flush_all (); exit 1) in
   match !Flags.compilation_mode with
   | BuildVo ->
       let long_f_dot_v = ensure_v f in
-      let ldir = Flags.verbosely Library.start_library long_f_dot_v 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;
+      ensure_exists long_f_dot_v;
+      let long_f_dot_vo =
+        match !Flags.compilation_output_name with
+        | None -> long_f_dot_v ^ "o"
+        | Some f -> ensure_vo long_f_dot_v f in
+      let ldir = Flags.verbosely Library.start_library long_f_dot_vo in
+      Stm.set_compilation_hints long_f_dot_vo;
+      Aux_file.(start_aux_file
+        ~aux_file:(aux_file_name_for long_f_dot_vo)
+        ~v_file:long_f_dot_v);
+      Dumpglob.start_dump_glob ~vfile:long_f_dot_v ~vofile:long_f_dot_vo;
       Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n");
       if !Flags.xml_export then Hook.get f_xml_start_library ();
       let wall_clock1 = Unix.gettimeofday () in
@@ -321,7 +312,7 @@ let compile verbosely f =
       Stm.join ();
       let wall_clock2 = Unix.gettimeofday () in
       check_pending_proofs ();
-      Library.save_library_to ldir long_f_dot_v (Global.opaque_tables ());
+      Library.save_library_to ldir long_f_dot_vo (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 ();
@@ -329,13 +320,18 @@ let compile verbosely f =
       Dumpglob.end_dump_glob ()
   | BuildVio ->
       let long_f_dot_v = ensure_v f in
-      let ldir = Flags.verbosely Library.start_library long_f_dot_v in
+      ensure_exists long_f_dot_v;
+      let long_f_dot_vio =
+        match !Flags.compilation_output_name with
+        | None -> long_f_dot_v ^ "io"
+        | Some f -> ensure_vio long_f_dot_v f in
+      let ldir = Flags.verbosely Library.start_library long_f_dot_vio in
       Dumpglob.noglob ();
-      Stm.set_compilation_hints long_f_dot_v;
+      Stm.set_compilation_hints long_f_dot_vio;
       let _ = load_vernac verbosely long_f_dot_v in
       Stm.finish ();
       check_pending_proofs ();
-      Stm.snapshot_vio ldir long_f_dot_v;
+      Stm.snapshot_vio ldir long_f_dot_vio;
       Stm.reset_task_queue ()
   | Vio2Vo ->
       let open Filename in
@@ -352,8 +348,5 @@ let compile v f =
   compile v f;
   CoqworkmgrApi.giveback 1
 
-let () = Hook.set Stm.process_error_hook (fun e ->
-  match !cur_file with
-  | None -> Cerrors.process_vernac_interp_error e
-  | Some f -> enrich_with_file f (Cerrors.process_vernac_interp_error e)
-)
+let () = Hook.set Stm.process_error_hook
+  ExplainErr.process_vernac_interp_error
diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli
index 008d7a31..0d9f5871 100644
--- a/toplevel/vernac.mli
+++ b/toplevel/vernac.mli
@@ -11,17 +11,14 @@
 (** Read a vernac command on the specified input (parse only).
    Raises [End_of_file] if EOF (or Ctrl-D) is reached. *)
 
-val parse_sentence : Pcoq.Gram.parsable * in_channel option ->
+val parse_sentence : Pcoq.Gram.coq_parsable * in_channel option ->
  Loc.t * Vernacexpr.vernac_expr
 
-(** Reads and executes vernac commands from a stream.
-   The boolean [just_parsing] disables interpretation of commands. *)
+(** Reads and executes vernac commands from a stream. *)
 
 exception End_of_input
 
-val just_parsing : bool ref
-
-val eval_expr : Loc.t * Vernacexpr.vernac_expr -> unit
+val process_expr : Pcoq.Gram.coq_parsable -> Loc.t * Vernacexpr.vernac_expr -> unit
 
 (** Set XML hooks *)
 val xml_start_library : (unit -> unit) Hook.t
@@ -38,9 +35,3 @@ val load_vernac : bool -> string -> unit
 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 72dd967b..41ee165f 100644
--- a/toplevel/vernacentries.ml
+++ b/toplevel/vernacentries.ml
@@ -9,7 +9,7 @@
 (* Concrete syntax of the mathematical vernacular MV V2.6 *)
 
 open Pp
-open Errors
+open CErrors
 open Util
 open Flags
 open Names
@@ -20,7 +20,6 @@ open Tacmach
 open Constrintern
 open Prettyp
 open Printer
-open Tacinterp
 open Command
 open Goptions
 open Libnames
@@ -32,10 +31,14 @@ open Redexpr
 open Lemmas
 open Misctypes
 open Locality
+open Sigma.Notations
+
+(** TODO: make this function independent of Ltac *)
+let (f_interp_redexp, interp_redexp_hook) = Hook.make ()
 
 let debug = false
-let prerr_endline =
-  if debug then prerr_endline else fun _ -> ()
+let prerr_endline x =
+  if debug then prerr_endline (x ()) else ()
 
 (* Misc *)
 
@@ -45,7 +48,7 @@ let cl_of_qualid = function
   | 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)
+  Notation.scope_class_of_class (cl_of_qualid qid)
 
 (*******************)
 (* "Show" commands *)
@@ -54,7 +57,7 @@ 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
-  msg_notice (Pp.prlist_with_sep Pp.fnl Printer.pr_constr pprf)
+  Feedback.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, 
@@ -62,22 +65,22 @@ let show_node () =
   ()
 
 let show_thesis () =
-     msg_error (anomaly (Pp.str "TODO") )
+     Feedback.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_notice (pr_evars_int sigma 1 (Evarutil.non_instantiated sigma))
+  Feedback.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
-    msg_notice (Evd.pr_evar_universe_context (Evd.evar_universe_context sigma));
-    msg_notice (str"Normalized constraints: " ++ Univ.pr_universe_context_set (Evd.pr_evd_level sigma) ctx)
+    Feedback.msg_notice (Evd.pr_evar_universe_context (Evd.evar_universe_context sigma));
+    Feedback.msg_notice (str"Normalized constraints: " ++ Univ.pr_universe_context_set (Evd.pr_evd_level sigma) ctx)
 
 let show_prooftree () =
   (* Spiwack: proof tree is currently not working *)
@@ -88,11 +91,10 @@ let enable_goal_printing = ref true
 let print_subgoals () =
   if !enable_goal_printing && is_verbose ()
   then begin
-    msg_notice (pr_open_subgoals ())
+    Feedback.msg_notice (pr_open_subgoals ())
   end
 
 let try_print_subgoals () =
-  Pp.flush_all();
   try print_subgoals () with Proof_global.NoCurrentProof | UserError _ -> ()
 
 
@@ -106,10 +108,10 @@ let show_intro all =
     let l,_= decompose_prod_assum (strip_outer_cast (pf_concl gl)) in
     if all then
       let lid = Tactics.find_intro_names l gl in
-      msg_notice (hov 0 (prlist_with_sep  spc pr_id lid))
+      Feedback.msg_notice (hov 0 (prlist_with_sep  spc pr_id lid))
     else if not (List.is_empty l) then
       let n = List.last l in
-      msg_notice (pr_id (List.hd (Tactics.find_intro_names [n] gl)))
+      Feedback.msg_notice (pr_id (List.hd (Tactics.find_intro_names [n] gl)))
   end
 
 (** Prepare a "match" template for a given inductive type.
@@ -118,9 +120,7 @@ let show_intro all =
     [Not_found] is raised if the given string isn't the qualid of
     a known inductive type. *)
 
-let make_cases s =
-  let qualified_name = Libnames.qualid_of_string s in
-  let glob_ref = Nametab.locate qualified_name in
+let make_cases_aux glob_ref =
   match glob_ref with
     | Globnames.IndRef i ->
 	let {Declarations.mind_nparams = np}
@@ -133,30 +133,35 @@ let make_cases s =
 	     let rec rename avoid = function
 	       | [] -> []
 	       | (n,_)::l ->
-		   let n' = Namegen.next_name_away_in_cases_pattern ([],mkMeta 0) n avoid in
+		   let n' = Namegen.next_name_away_with_default (Id.to_string Namegen.default_dependent_ident) n avoid in
 		   Id.to_string n' :: rename (n'::avoid) l in
 	     let al' = rename [] al in
 	     (Id.to_string consname :: al') :: l)
 	  carr tarr []
     | _ -> raise Not_found
 
+let make_cases s =
+  let qualified_name = Libnames.qualid_of_string s in
+  let glob_ref = Nametab.locate qualified_name in
+  make_cases_aux glob_ref
+
 (** Textual display of a generic "match" template *)
 
 let show_match id =
   let patterns =
-    try make_cases (Id.to_string (snd id))
+    try make_cases_aux (Nametab.global 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_notice (v 1 (str "match # with" ++ fnl () ++
+  Feedback.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 p =
-  let dir = str (DirPath.to_string (Loadpath.logical p)) in
+  let dir = pr_dirpath (Loadpath.logical p) in
   let path = str (Loadpath.physical p) in
   (dir ++ str " " ++ tbrk (0, 0) ++ path)
 
@@ -191,23 +196,23 @@ let print_module r =
     let globdir = Nametab.locate_dir qid in
       match globdir with
 	  DirModule (dirpath,(mp,_)) ->
-	    msg_notice (Printmod.print_module (Printmod.printable_body dirpath) mp)
+	    Feedback.msg_notice (Printmod.print_module (Printmod.printable_body dirpath) mp)
 	| _ -> raise Not_found
   with
-      Not_found -> msg_error (str"Unknown Module " ++ pr_qualid qid)
+      Not_found -> Feedback.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
-    msg_notice (Printmod.print_modtype kn)
+    Feedback.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
-      msg_notice (Printmod.print_module false mp)
+      Feedback.msg_notice (Printmod.print_module false mp)
     with Not_found ->
-      msg_error (str"Unknown Module Type or Module " ++ pr_qualid qid)
+      Feedback.msg_error (str"Unknown Module Type or Module " ++ pr_qualid qid)
 
 let print_namespace ns =
   let ns = List.rev (Names.DirPath.repr ns) in
@@ -276,7 +281,7 @@ let print_namespace ns =
         acc
     ) constants (str"")
   in
-  msg_notice ((print_list pr_id ns)++str":"++fnl()++constants_in_namespace)
+  Feedback.msg_notice ((print_list pr_id ns)++str":"++fnl()++constants_in_namespace)
 
 let print_strategy r =
   let open Conv_oracle in
@@ -306,7 +311,7 @@ let print_strategy r =
       else str "Constant strategies" ++ fnl () ++
         hov 0 (prlist_with_sep fnl pr_strategy cst_lvl)
     in
-    msg_notice (var_msg ++ cst_msg)
+    Feedback.msg_notice (var_msg ++ cst_msg)
   | Some r ->
     let r = Smartlocate.smart_global r in
     let key = match r with
@@ -315,7 +320,7 @@ let print_strategy r =
     | IndRef _ | ConstructRef _ -> error "The reference is not unfoldable"
     in
     let lvl = get_strategy oracle key in
-    msg_notice (pr_strategy (r, lvl))
+    Feedback.msg_notice (pr_strategy (r, lvl))
 
 let dump_universes_gen g s =
   let output = open_out s in
@@ -333,7 +338,7 @@ let dump_universes_gen g s =
           | Univ.Eq ->
             Printf.fprintf output "  \"%s\" -> \"%s\" [style=dashed];\n" left right
       end, begin fun () ->
-        if Lazy.lazy_is_val init then Printf.fprintf output "}\n";
+        if Lazy.is_val init then Printf.fprintf output "}\n";
         close_out output
       end
     end else begin
@@ -347,11 +352,11 @@ let dump_universes_gen g s =
     end
   in
   try
-    Univ.dump_universes output_constraint g;
+    UGraph.dump_universes output_constraint g;
     close ();
-    msg_info (str "Universes written to file \"" ++ str s ++ str "\".")
+    Feedback.msg_info (str "Universes written to file \"" ++ str s ++ str "\".")
   with reraise ->
-    let reraise = Errors.push reraise in
+    let reraise = CErrors.push reraise in
     close ();
     iraise reraise
 
@@ -364,11 +369,11 @@ let locate_file f =
 
 let msg_found_library = function
   | Library.LibLoaded, fulldir, file ->
-      msg_info (hov 0
+      Feedback.msg_info (hov 0
 	(pr_dirpath fulldir ++ strbrk " has been loaded from file " ++
 	 str file))
   | Library.LibInPath, fulldir, file ->
-      msg_info (hov 0
+      Feedback.msg_info (hov 0
 	(pr_dirpath fulldir ++ strbrk " is bound to file " ++ str file))
 
 let err_unmapped_library loc ?from qid =
@@ -409,7 +414,7 @@ let dump_global r =
   try
     let gr = Smartlocate.smart_global r in
     Dumpglob.add_glob (Constrarg.loc_of_or_by_notation loc_of_reference r) gr
-  with e when Errors.noncritical e -> ()
+  with e when CErrors.noncritical e -> ()
 (**********)
 (* Syntax *)
 
@@ -443,7 +448,27 @@ let vernac_notation locality local =
 (***********)
 (* Gallina *)
 
-let start_proof_and_print k l hook = start_proof_com k l hook
+let start_proof_and_print k l hook =
+  let inference_hook =
+    if Flags.is_program_mode () then
+      let hook env sigma ev =
+        let tac = !Obligations.default_tactic in
+        let evi = Evd.find sigma ev in
+        let env = Evd.evar_filtered_env evi in
+        try
+          let concl = Evarutil.nf_evars_universes sigma evi.Evd.evar_concl in
+          if Evarutil.has_undefined_evars sigma concl then raise Exit;
+          let c, _, ctx =
+            Pfedit.build_by_tactic env (Evd.evar_universe_context sigma)
+                                   concl (Tacticals.New.tclCOMPLETE tac)
+          in Evd.set_universe_context sigma ctx, c
+        with Logic_monad.TacticFailure e when Logic.catchable_exception e ->
+          error "The statement obligations could not be resolved \
+                 automatically, write a statement definition first."
+      in Some hook
+    else None
+  in
+  start_proof_com ?inference_hook k l hook
 
 let no_hook = Lemmas.mk_hook (fun _ _ -> ())
 
@@ -463,14 +488,14 @@ let vernac_definition locality p (local,k) ((loc,id as lid),pl) def =
   in
   (match def with
     | ProveBody (bl,t) ->   (* local binders, typ *)
- 	  start_proof_and_print (local,p,DefinitionBody Definition)
-	    [Some (lid,pl), (bl,t,None)] no_hook
+	  start_proof_and_print (local,p,DefinitionBody k)
+	    [Some (lid,pl), (bl,t,None)] 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
+ 		Some (snd (Hook.get f_interp_redexp env evc r)) in
 	do_definition id (local,p,k) pl bl red_option c typ_opt hook)
 
 let vernac_start_proof locality p kind l lettop =
@@ -501,9 +526,9 @@ let vernac_end_proof ?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 status = by (Tactics.New.exact_proof c) in
+  let status = by (Tactics.exact_proof c) in
   save_proof (Vernacexpr.(Proved(Opaque None,None)));
-  if not status then Pp.feedback Feedback.AddedAxiom
+  if not status then Feedback.feedback Feedback.AddedAxiom
 
 let vernac_assumption locality poly (local, kind) l nl =
   let local = enforce_locality_exp locality local in
@@ -515,7 +540,7 @@ let vernac_assumption locality poly (local, kind) l nl =
 	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
+  if not status then Feedback.feedback Feedback.AddedAxiom
 
 let vernac_record k poly finite struc binders sort nameopt cfs =
   let const = match nameopt with
@@ -530,6 +555,10 @@ let vernac_record k poly finite struc binders sort nameopt cfs =
 	| _ -> ()) cfs);
     ignore(Record.definition_structure (k,poly,finite,struc,binders,cfs,const,sort))
 
+(** When [poly] is true the type is declared polymorphic. When [lo] is true,
+    then the type is declared private (as per the [Private] keyword). [finite]
+    indicates whether the type is inductive, co-inductive or
+    neither. *)
 let vernac_inductive poly lo finite indl =
   if Dumpglob.dump () then
     List.iter (fun (((coe,(lid,_)), _, _, _, cstrs), _) ->
@@ -542,29 +571,29 @@ let vernac_inductive poly lo finite indl =
       indl;
   match indl with
   | [ ( _ , _ , _ ,Record, Constructors _ ),_ ] ->
-      Errors.error "The Record keyword cannot be used to define a variant type. Use Variant instead."
+      CErrors.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."
+      CErrors.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)
+      vernac_record (match b with Class _ -> Class false | _ -> b)
        poly finite id bl c oc fs
-  | [ ( id , bl , c , Class true, Constructors [l]), _ ] ->
+  | [ ( id , bl , c , Class _, 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) poly finite id bl c None [f]
-  | [ ( id , bl , c , Class true, _), _ ] ->
-      Errors.error "Definitional classes must have a single method"
-  | [ ( id , bl , c , Class false, Constructors _), _ ] ->
-      Errors.error "Inductive classes not supported"
+  | [ ( _ , _, _, Class _, Constructors _), [] ] ->
+      CErrors.error "Inductive classes not supported"
+  | [ ( id , bl , c , Class _, _), _ :: _ ] ->
+      CErrors.error "where clause not supported for classes"
   | [ ( _ , _ , _ , _, RecordDecl _ ) , _ ] ->
-      Errors.error "where clause not supported for (co)inductive records"
+      CErrors.error "where clause not supported for (co)inductive records"
   | _ -> let unpack = function
       | ( (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."
+          CErrors.error "Variant types do not handle the \"> Name\" syntax, which is reserved for records. Use the \":>\" syntax on constructors instead."
+      | _ -> CErrors.error "Cannot handle mutually (co)inductive records."
     in
     let indl = List.map unpack indl in
     do_mutual_inductive indl poly lo finite
@@ -633,7 +662,7 @@ let vernac_declare_module export (loc, id) binders_ast mty_ast =
       id binders_ast (Enforce mty_ast) []
   in
   Dumpglob.dump_moddef loc mp "mod";
-  if_verbose msg_info (str "Module " ++ pr_id id ++ str " is declared");
+  if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " 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 =
@@ -654,7 +683,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l =
            export id binders_ast mty_ast_o
        in
        Dumpglob.dump_moddef loc mp "mod";
-       if_verbose msg_info
+       if_verbose Feedback.msg_info
          (str "Interactive Module " ++ pr_id id ++ str " started");
        List.iter
          (fun (export,id) ->
@@ -672,7 +701,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l =
 	   id binders_ast mty_ast_o mexpr_ast_l
        in
        Dumpglob.dump_moddef loc mp "mod";
-       if_verbose msg_info
+       if_verbose Feedback.msg_info
 	 (str "Module " ++ pr_id id ++ str " is defined");
        Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)])
          export
@@ -680,7 +709,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l =
 let vernac_end_module export (loc,id as lid) =
   let mp = Declaremods.end_module () in
   Dumpglob.dump_modref loc mp "mod";
-  if_verbose msg_info (str "Module " ++ pr_id id ++ str " is defined");
+  if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " 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 =
@@ -701,7 +730,7 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l =
            id binders_ast mty_sign
        in
        Dumpglob.dump_moddef loc mp "modtype";
-       if_verbose msg_info
+       if_verbose Feedback.msg_info
 	 (str "Interactive Module Type " ++ pr_id id ++ str " started");
        List.iter
          (fun (export,id) ->
@@ -720,13 +749,13 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l =
 	    id binders_ast mty_sign mty_ast_l
         in
         Dumpglob.dump_moddef loc mp "modtype";
-	if_verbose msg_info
+	if_verbose Feedback.msg_info
 	  (str "Module Type " ++ pr_id id ++ str " is defined")
 
 let vernac_end_modtype (loc,id) =
   let mp = Declaremods.end_modtype () in
   Dumpglob.dump_modref loc mp "modtype";
-  if_verbose msg_info (str "Module Type " ++ pr_id id ++ str " is defined")
+  if_verbose Feedback.msg_info (str "Module Type " ++ pr_id id ++ str " is defined")
 
 let vernac_include l =
   Declaremods.declare_include Modintern.interp_module_ast l
@@ -794,7 +823,7 @@ let vernac_coercion locality poly local ref qids qidt =
   let source = cl_of_qualid qids in
   let ref' = smart_global ref in
   Class.try_add_new_coercion_with_target ref' ~local poly ~source ~target;
-  if_verbose msg_info (pr_global ref' ++ str " is now a coercion")
+  if_verbose Feedback.msg_info (pr_global ref' ++ str " is now a coercion")
 
 let vernac_identity_coercion locality poly local id qids qidt =
   let local = enforce_locality locality local in
@@ -810,11 +839,11 @@ let vernac_instance abst locality poly sup inst props pri =
   ignore(Classes.new_instance ~abstract:abst ~global poly sup inst props pri)
 
 let vernac_context poly l =
-  if not (Classes.context poly l) then Pp.feedback Feedback.AddedAxiom
+  if not (Classes.context poly l) then Feedback.feedback Feedback.AddedAxiom
 
-let vernac_declare_instances locality ids pri =
+let vernac_declare_instances locality insts =
   let glob = not (make_section_locality locality) in
-  List.iter (fun id -> Classes.existing_instance glob id pri) ids
+  List.iter (fun (id, info) -> Classes.existing_instance glob id (Some info)) insts
 
 let vernac_declare_class id =
   Record.declare_existing_class (Nametab.global id)
@@ -825,35 +854,6 @@ let vernac_declare_class id =
 let command_focus = Proof.new_focus_kind ()
 let focus_command_cond = Proof.no_cond command_focus
 
-
-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 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 *)
-    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
      added by Christine to patch an error in the design of the proof
      machine, and enables to instantiate existential variables when
@@ -871,31 +871,36 @@ let vernac_set_end_tac tac =
     (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*)
 
 let vernac_set_used_variables e =
+  let open Context.Named.Declaration in
   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.equal id id') vars) then
+    if not (List.exists (Id.equal id % get_id) vars) then
       errorlabstrm "vernac_set_used_variables"
         (str "Unknown variable: " ++ pr_id id))
     l;
   let _, to_clear = set_used_variables l in
-  vernac_solve
-    SelectAll None Tacexpr.(TacAtom (Loc.ghost,TacClear(false,to_clear))) false
-
+  let to_clear = List.map snd to_clear in
+  Proof_global.with_current_proof begin fun _ p ->
+    if List.is_empty to_clear then (p, ())
+    else
+      let tac = Tactics.clear to_clear in
+      fst (solve SelectAll None tac p), ()
+  end
 
 (*****************************)
 (* Auxiliary file management *)
 
 let expand filename =
-  Envars.expand_path_macros ~warn:(fun x -> msg_warning (str x)) filename
+  Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) filename
 
 let vernac_add_loadpath implicit pdir ldiropt =
   let pdir = expand pdir in
   let alias = Option.default Nameops.default_root_prefix ldiropt in
-  Mltop.add_rec_path ~unix_path:pdir ~coq_root:alias ~implicit
+  Mltop.add_rec_path Mltop.AddTopML ~unix_path:pdir ~coq_root:alias ~implicit
 
 let vernac_remove_loadpath path =
   Loadpath.remove_load_path (expand path)
@@ -910,13 +915,17 @@ let vernac_declare_ml_module locality l =
   Mltop.declare_ml_modules local (List.map expand l)
 
 let vernac_chdir = function
-  | None -> msg_notice (str (Sys.getcwd()))
+  | None -> Feedback.msg_notice (str (Sys.getcwd()))
   | Some path ->
       begin
 	try Sys.chdir (expand path)
-	with Sys_error err -> msg_warning (str "Cd failed: " ++ str err)
+	with Sys_error err ->
+	  (* Cd is typically used to control the output directory of
+	  extraction. A failed Cd could lead to overwriting .ml files
+	  so we make it an error. *)
+	  CErrors.error ("Cd failed: " ^ err)
       end;
-      if_verbose msg_info (str (Sys.getcwd()))
+      if_verbose Feedback.msg_info (str (Sys.getcwd()))
 
 
 (********************)
@@ -935,85 +944,6 @@ let vernac_restore_state file =
 (************)
 (* Commands *)
 
-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 recvars =
-    let fold accu (op, _) = match op with
-    | UpdateTac _ -> accu
-    | NewTac id -> (Lib.make_path id, Lib.make_kn id) :: accu
-    in
-    if isrec then List.fold_left fold [] rfun
-    else []
-  in
-  let ist = Tacintern.make_empty_glob_sign () 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 () =
-    (** Register locally the tactic to handle recursivity. This function affects
-        the whole environment, so that we transactify it afterwards. *)
-    let iter_rec (sp, kn) = Nametab.push_tactic (Nametab.Until 1) sp kn in
-    let () = List.iter iter_rec recvars in
-    List.map map rfun
-  in
-  let defs = Future.transactify defs () 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_declare_tactic_definition locality (x,def) =
-  let local = make_module_locality locality in
-  register_ltac local x def
-
 let vernac_create_hintdb locality id b =
   let local = make_module_locality locality in
   Hints.create_hint_db local id full_transparent_state b
@@ -1040,141 +970,265 @@ let vernac_declare_implicits locality r l =
       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 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 (fun na -> not (List.equal Name.equal na names)) rest then
-    error "All arguments lists must declare the same names.";
-  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 warn_arguments_assert =
+  CWarnings.create ~name:"arguments-assert" ~category:"vernacular"
+         (fun sr ->
+          strbrk "This command is just asserting the names of arguments of " ++
+            pr_global sr ++ strbrk". If this is what you want add " ++
+            strbrk "': assert' to silence the warning. If you want " ++
+            strbrk "to clear implicit arguments add ': clear implicits'. " ++
+            strbrk "If you want to clear notation scopes add ': clear scopes'")
+
+(* [nargs_for_red] is the number of arguments required to trigger reduction,
+   [args] is the main list of arguments statuses,
+   [more_implicits] is a list of extra lists of implicit statuses  *)
+let vernac_arguments locality reference args more_implicits nargs_for_red flags =
+  let assert_flag = List.mem `Assert flags in
+  let rename_flag = List.mem `Rename flags in
+  let clear_scopes_flag = List.mem `ClearScopes flags in
+  let extra_scopes_flag = List.mem `ExtraScopes flags in
+  let clear_implicits_flag = List.mem `ClearImplicits flags in
+  let default_implicits_flag = List.mem `DefaultImplicits flags in
+  let never_unfold_flag = List.mem `ReductionNeverUnfold flags in
+
+  let err_incompat x y =
+    error ("Options \""^x^"\" and \""^y^"\" are incompatible.") in
+
+  if assert_flag && rename_flag then
+    err_incompat "assert" "rename";
+  if Option.has_some nargs_for_red && never_unfold_flag then
+    err_incompat "simpl never" "/";
+  if never_unfold_flag && List.mem `ReductionDontExposeCase flags then
+    err_incompat "simpl never" "simpl nomatch";
+  if clear_scopes_flag && extra_scopes_flag then
+    err_incompat "clear scopes" "extra scopes";
+  if clear_implicits_flag && default_implicits_flag then
+    err_incompat "clear implicits" "default implicits";
+
+  let sr = smart_global reference in
   let inf_names =
     let ty = Global.type_of_global_unsafe sr in
-      Impargs.compute_implicits_names (Global.env ()) ty in
-  let rec check li ld ls = match li, ld, ls with
-    | [], [], [] -> ()
-    | [], Anonymous::ld, (Some _)::ls when extra_scope_flag -> check li ld ls
-    | [], _::_, (Some _)::ls when extra_scope_flag ->
-       error "Extra notation scopes can be set on anonymous arguments only"
-    | [], x::_, _ -> errorlabstrm "vernac_declare_arguments"
-                       (str "Extra argument " ++ pr_name x ++ str ".")
-    | l, [], _ -> errorlabstrm "vernac_declare_arguments"
-                    (str "The following arguments are not declared: " ++
-                       prlist_with_sep pr_comma pr_name l ++ str ".")
-    | _::li, _::ld, _::ls -> check li ld ls 
-    | _ -> assert false in
-  let () = match l with
-  | [[]] -> ()
-  | _ ->
-    List.iter2 (fun l -> check inf_names l) (names :: rest) scopes
+    Impargs.compute_implicits_names (Global.env ()) ty
   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
-      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
-    l, scopes in
-  (* we interpret _ as the inferred names *)
-  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
-    List.map (fun ns -> List.map name_anons (List.combine ns inf_names)) l in
-  let names_decl = List.map (List.map (fun (id, _,_,_,_) -> id)) l in
-  let renamed_arg = ref None in
-  let set_renamed a b =
-    if Option.is_empty !renamed_arg && not (Id.equal a b) then renamed_arg := Some(b,a) in
-  let some_renaming_specified =
-    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 =
-    match l with
-    | [[]] -> false, [[]]
+  let prev_names =
+    try Arguments_renaming.arguments_names sr with Not_found -> inf_names
+  in
+  let num_args = List.length inf_names in
+  assert (Int.equal num_args (List.length prev_names));
+
+  let names_of args = List.map (fun a -> a.name) args in
+
+  (* Checks *)
+
+  let err_extra_args names =
+    errorlabstrm "vernac_declare_arguments"
+                 (strbrk "Extra arguments: " ++
+                    prlist_with_sep pr_comma pr_name names ++ str ".")
+  in
+  let err_missing_args names =
+    errorlabstrm "vernac_declare_arguments"
+                 (strbrk "The following arguments are not declared: " ++
+                    prlist_with_sep pr_comma pr_name names ++ str ".")
+  in
+
+  let rec check_extra_args extra_args =
+    match extra_args with
+    | [] -> ()
+    | { notation_scope = None } :: _ -> err_extra_args (names_of extra_args)
+    | { name = Anonymous; notation_scope = Some _ } :: args ->
+       check_extra_args args
     | _ ->
-    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 ->
-            errorlabstrm "vernac_declare_arguments"
-              (str "Argument " ++ pr_id x ++ str " cannot be declared implicit.")
-        | (Name iid, _,_, true, max), Name id ->
-           set_renamed iid id;
-           b || not (Id.equal iid id), Some (ExplByName id, max, false)
-        | (Name iid, _,_, _, _), Name id ->
-           set_renamed iid id;
-           b || not (Id.equal iid id), None
-        | _ -> b, None)
-        sr (List.combine il inf_names) in
-      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
-      errorlabstrm "vernac_declare_arguments"
-        (str "To rename arguments the \"rename\" flag must be specified." ++
-           match !renamed_arg with
-           | None -> mt ()
-           | Some (o,n) ->
-              str "\nArgument " ++ pr_id o ++ str " renamed to " ++ pr_id n ++ str ".")
-    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 = match implicits with
-  | [[]] -> false | _ -> true in
-  let scopes = List.map (function
-    | None -> None
-    | Some (o, k) ->
-        try ignore (Notation.find_scope k); Some k
-        with UserError _ ->
-          Some (Notation.find_delimiters_scope o k)) scopes
+       error "Extra notation scopes can be set on anonymous and explicit arguments only."
+  in
+
+  let args, scopes =
+    let scopes = List.map (fun { notation_scope = s } -> s) args in
+    if List.length args > num_args then
+      let args, extra_args = List.chop num_args args in
+      if extra_scopes_flag then
+        (check_extra_args extra_args; (args, scopes))
+      else err_extra_args (names_of extra_args)
+    else args, scopes
+  in
+
+  if Option.cata (fun n -> n > num_args) false nargs_for_red then
+    error "The \"/\" modifier should be put before any extra scope.";
+
+  let scopes_specified = List.exists Option.has_some scopes in
+  
+  if scopes_specified && clear_scopes_flag then
+    error "The \"clear scopes\" flag is incompatible with scope annotations.";
+
+  let names = List.map (fun { name } -> name) args in
+  let names = names :: List.map (List.map fst) more_implicits in
+
+  let rename_flag_required = ref false in
+  let example_renaming = ref None in
+  let save_example_renaming renaming =
+    rename_flag_required := !rename_flag_required
+                            || not (Name.equal (fst renaming) Anonymous);
+    if Option.is_empty !example_renaming then
+      example_renaming := Some renaming
   in
-  let some_scopes_specified = List.exists ((!=) None) scopes in
+
+  let rec names_union names1 names2 =
+    match names1, names2 with
+    | [], [] -> []
+    | _ :: _, [] -> names1
+    | [], _ :: _ -> names2
+    | (Name _ as name) :: names1, Anonymous :: names2
+    | Anonymous :: names1, (Name _ as name) :: names2 ->
+       name :: names_union names1 names2
+    | name1 :: names1, name2 :: names2 ->
+       if Name.equal name1 name2 then
+         name1 :: names_union names1 names2
+       else error "Argument lists should agree on the names they provide."
+  in
+
+  let names = List.fold_left names_union [] names in
+
+  let rec rename prev_names names =
+    match prev_names, names with
+    | [], [] -> []
+    | [], _ :: _ -> err_extra_args names
+    | _ :: _, [] when assert_flag ->
+       (* Error messages are expressed in terms of original names, not
+            renamed ones. *)
+       err_missing_args (List.lastn (List.length prev_names) inf_names)
+    | _ :: _, [] -> prev_names
+    | prev :: prev_names, Anonymous :: names ->
+       prev :: rename prev_names names
+    | prev :: prev_names, (Name id as name) :: names ->
+       if not (Name.equal prev name) then save_example_renaming (prev,name);
+       name :: rename prev_names names
+  in
+  
+  let names = rename prev_names names in
+  let renaming_specified = Option.has_some !example_renaming in
+
+  if !rename_flag_required && not rename_flag then
+    errorlabstrm "vernac_declare_arguments"
+      (strbrk "To rename arguments the \"rename\" flag must be specified."
+    ++ spc () ++
+       match !example_renaming with
+       | None -> mt ()
+       | Some (o,n) ->
+          str "Argument " ++ pr_name o ++
+            str " renamed to " ++ pr_name n ++ str ".");
+
+  let duplicate_names =
+    List.duplicates Name.equal (List.filter ((!=) Anonymous) names)
+  in
+  if not (List.is_empty duplicate_names) then begin
+    let duplicates = prlist_with_sep pr_comma pr_name duplicate_names in
+    errorlabstrm "_" (strbrk "Some argument names are duplicated: " ++ duplicates)
+  end;
+
+  (* Parts of this code are overly complicated because the implicit arguments
+     API is completely crazy: positions (ExplByPos) are elaborated to
+     names. This is broken by design, since not all arguments have names. So
+     even though we eventually want to map only positions to implicit statuses,
+     we have to check whether the corresponding arguments have names, not to
+     trigger an error in the impargs code. Even better, the names we have to
+     check are not the current ones (after previous renamings), but the original
+     ones (inferred from the type). *)
+
+  let implicits =
+    List.map (fun { name; implicit_status = i } -> (name,i)) args
+  in
+  let implicits = implicits :: more_implicits in
+
+  let open Vernacexpr in
+  let rec build_implicits inf_names implicits =
+    match inf_names, implicits with
+    | _, [] -> []
+    | _ :: inf_names, (_, NotImplicit) :: implicits ->
+       build_implicits inf_names implicits
+
+    (* With the current impargs API, it is impossible to make an originally
+       anonymous argument implicit *)
+    | Anonymous :: _, (name, _) :: _ ->
+       errorlabstrm "vernac_declare_arguments"
+                    (strbrk"Argument "++ pr_name name ++ 
+                       strbrk " cannot be declared implicit.")
+
+    | Name id :: inf_names, (name, impl) :: implicits ->
+       let max = impl = MaximallyImplicit in
+       (ExplByName id,max,false) :: build_implicits inf_names implicits
+    
+    | _ -> assert false (* already checked in [names_union] *)
+  in
+  
+  let implicits = List.map (build_implicits inf_names) implicits in
+  let implicits_specified = match implicits with [[]] -> false | _ -> true in
+
+  if implicits_specified && clear_implicits_flag then
+    error "The \"clear implicits\" flag is incompatible with implicit annotations";
+
+  if implicits_specified && default_implicits_flag then
+    error "The \"default implicits\" flag is incompatible with implicit annotations";
+
   let rargs =
     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 locality r scopes;
-  if not some_implicits_specified && List.mem `DefaultImplicits flags then
-    vernac_declare_implicits locality r []
-  else if some_implicits_specified || List.mem `ClearImplicits flags then
-    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 no_flags = List.is_empty flags in
+      (Util.List.map_i (fun i { recarg_like = b } -> i, b) 0 args)
+  in
+
   let rec narrow = function
     | #Reductionops.ReductionBehaviour.flag as x :: tl -> x :: narrow tl
-    | [] -> [] | _ :: tl -> narrow tl in
-  let flags = narrow flags in
-  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
+    | [] -> [] | _ :: tl -> narrow tl
+  in
+  let red_flags = narrow flags in
+  let red_modifiers_specified =
+    not (List.is_empty rargs) || Option.has_some nargs_for_red
+    || not (List.is_empty red_flags)
+  in
+
+  if not (List.is_empty rargs) && never_unfold_flag then
+    err_incompat "simpl never" "!";
+
+
+  (* Actions *)
+
+  if renaming_specified then begin
+    let local = make_section_locality locality in
+    Arguments_renaming.rename_arguments local sr names
+  end;
+
+  if scopes_specified || clear_scopes_flag then begin
+      let scopes = List.map (Option.map (fun (o,k) -> 
+        try ignore (Notation.find_scope k); k
+        with UserError _ ->
+          Notation.find_delimiters_scope o k)) scopes
+      in
+      vernac_arguments_scope locality reference scopes
+    end;
+
+  if implicits_specified || clear_implicits_flag then
+    vernac_declare_implicits locality reference implicits;
+
+  if default_implicits_flag then
+    vernac_declare_implicits locality reference [];
+
+  if red_modifiers_specified then begin
     match sr with
     | ConstRef _ as c ->
        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.")
+         (make_section_locality locality) c
+         (rargs, Option.default ~-1 nargs_for_red, red_flags)
+    | _ -> errorlabstrm ""
+             (strbrk "Modifiers of the behavior of the simpl tactic "++
+              strbrk "are relevant for constants only.")
   end;
-  if not (some_renaming_specified ||
-          some_implicits_specified ||
-          some_scopes_specified ||
-          some_simpl_flags_specified) &&
-     no_flags 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'")
 
+ if not (renaming_specified ||
+         implicits_specified ||
+         scopes_specified ||
+         red_modifiers_specified) && (List.is_empty flags) then
+    warn_arguments_assert sr
 
 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 =
@@ -1183,7 +1237,7 @@ let vernac_reserve bl =
     let sigma = Evd.from_env env in
     let t,ctx = Constrintern.interp_type env sigma c in
     let t = Detyping.detype false [] env (Evd.from_ctx ctx) t in
-    let t = Notation_ops.notation_constr_of_glob_constr (default_env ()) 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
 
@@ -1370,8 +1424,8 @@ let _ =
       optdepr  = false;
       optname  = "kernel term sharing";
       optkey   = ["Kernel"; "Term"; "Sharing"];
-      optread  = (fun () -> !Closure.share);
-      optwrite = (fun b -> Closure.share := b) }
+      optread  = (fun () -> !CClosure.share);
+      optwrite = (fun b -> CClosure.share := b) }
 
 (* No more undo limit in the new proof engine.
    The command still exists for compatibility (e.g. with ProofGeneral) *)
@@ -1430,18 +1484,6 @@ let _ =
       optread  = Flags.get_dump_bytecode;
       optwrite = Flags.set_dump_bytecode }
 
-let vernac_debug b =
-  set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff)
-
-let _ =
-  declare_bool_option
-    { optsync  = false;
-      optdepr  = false;
-      optname  = "Ltac debug";
-      optkey   = ["Ltac";"Debug"];
-      optread  = (fun () -> get_debug () != Tactic_debug.DebugOff);
-      optwrite = vernac_debug }
-
 let _ =
   declare_bool_option
     { optsync  = true;
@@ -1451,6 +1493,15 @@ let _ =
       optread  = (fun () -> !Constrintern.parsing_explicit);
       optwrite = (fun b ->  Constrintern.parsing_explicit := b) }
 
+let _ =
+  declare_string_option ~preprocess:CWarnings.normalize_flags_string
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "warnings display";
+      optkey   = ["Warnings"];
+      optread  = CWarnings.get_flags;
+      optwrite = CWarnings.set_flags }
+
 let vernac_set_strategy locality l =
   let local = make_locality locality in
   let glob_ref r =
@@ -1480,6 +1531,9 @@ let vernac_set_option locality key = function
   | IntValue n -> set_int_option_value_gen locality key n
   | BoolValue b -> set_bool_option_value_gen locality key b
 
+let vernac_set_append_option locality key s =
+  set_string_option_append_value_gen locality key s
+
 let vernac_unset_option locality key =
   unset_option_value_gen locality key
 
@@ -1519,7 +1573,7 @@ let get_current_context_of_args = function
 let vernac_check_may_eval redexp glopt rc =
   let (sigma, env) = get_current_context_of_args glopt in
   let sigma', c = interp_open_constr env sigma rc in
-  let sigma' = Evarconv.consider_remaining_unif_problems env sigma' in
+  let sigma' = Evarconv.solve_unif_constraints_with_heuristics env sigma' in
   Evarconv.check_problems_are_solved env sigma';
   let sigma',nf = Evarutil.nf_evars_and_universes sigma' in
   let pl, uctx = Evd.universe_context sigma' in
@@ -1535,18 +1589,22 @@ let vernac_check_may_eval redexp glopt rc =
     | None ->
         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 ++
+	Feedback.msg_notice (print_judgment env sigma' j ++
                     pr_ne_evar_set (fnl () ++ str "where" ++ fnl ()) (mt ()) sigma' l ++
                     Printer.pr_universe_ctx sigma uctx)
     | Some r ->
-        Tacintern.dump_glob_red_expr r;
-        let (sigma',r_interp) = interp_redexp env sigma' r in
-	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 (sigma',r_interp) = Hook.get f_interp_redexp env sigma' r in
+	let redfun env evm c =
+          let (redfun, _) = reduction_of_red_expr env r_interp in
+          let evm = Sigma.Unsafe.of_evar_map evm in
+          let Sigma (c, _, _) = redfun.Reductionops.e_redfun env evm c in
+          c
+        in
+	Feedback.msg_notice (print_eval redfun env sigma' rc j)
 
 let vernac_declare_reduction locality s r =
   let local = make_locality locality in
-  declare_red_expr local s (snd (interp_redexp (Global.env()) Evd.empty r))
+  declare_red_expr local s (snd (Hook.get f_interp_redexp (Global.env()) Evd.empty r))
 
   (* The same but avoiding the current goal context if any *)
 let vernac_global_check c =
@@ -1554,11 +1612,11 @@ let vernac_global_check c =
   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 Univ.UContext.empty ctx) in
+  let cstrs = snd (UState.context_set ctx) in
   let senv = Safe_typing.add_constraints cstrs senv in
   let j = Safe_typing.typing senv c in
   let env = Safe_typing.env_of_safe_env senv in
-    msg_notice (print_safe_judgment env sigma j)
+    Feedback.msg_notice (print_safe_judgment env sigma j)
 
 
 let get_nth_goal n =
@@ -1572,6 +1630,7 @@ exception NoHyp
    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 =
+  let open Context.Named.Declaration in
   try
     let gl,id =
       match glnumopt,ref_or_by_not with
@@ -1584,17 +1643,17 @@ let print_about_hyp_globs ref_or_by_not glnumopt =
                            (str "No such goal: " ++ int n ++ str "."))
       | _ , _ -> 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()
+    let decl = Context.Named.lookup id hyps in
+    let natureofid = match decl with
+                     | LocalAssum _ -> "Hypothesis"
+                     | LocalDef (_,bdy,_) ->"Constant (let in)" in
+    v 0 (pr_id id ++ str":" ++ pr_constr (get_type decl) ++ 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
+let vernac_print = let open Feedback in function
   | PrintTables -> msg_notice (print_tables ())
   | PrintFullContext-> msg_notice (print_full_context_typ ())
   | PrintSectionContext qid -> msg_notice (print_sec_context_typ qid)
@@ -1613,26 +1672,24 @@ let vernac_print = function
   | 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) ->
       msg_notice (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt))
   | PrintCanonicalConversions -> msg_notice (Prettyp.print_canonical_projections ())
   | PrintUniverses (b, dst) ->
      let univ = Global.universes () in
-     let univ = if b then Univ.sort_universes univ else univ in
+     let univ = if b then UGraph.sort_universes univ else univ in
      let pr_remaining =
        if Global.is_joined_environment () then mt ()
        else str"There may remain asynchronous universe constraints"
      in
      begin match dst with
-     | None -> msg_notice (Univ.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining)
+     | None -> msg_notice (UGraph.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining)
      | Some s -> dump_universes_gen univ s
      end
   | 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 ->
       msg_notice (Notation.pr_scopes (Constrextern.without_symbols pr_lglob_constr))
@@ -1684,6 +1741,28 @@ let interp_search_about_item env =
 	errorlabstrm "interp_search_about_item"
           (str "Unable to interp \"" ++ str s ++ str "\" either as a reference or as an identifier component")
 
+(* 05f22a5d6d5b8e3e80f1a37321708ce401834430 introduced the
+   `search_output_name_only` option to avoid excessive printing when
+   searching.
+
+   The motivation was to make search usable for IDE completion,
+   however, it is still too slow due to the non-indexed nature of the
+   underlying search mechanism.
+
+   In the future we should deprecate the option and provide a fast,
+   indexed name-searching interface.
+*)
+let search_output_name_only = ref false
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "output-name-only search";
+      optkey   = ["Search";"Output";"Name";"Only"];
+      optread  = (fun () -> !search_output_name_only);
+      optwrite = (:=) search_output_name_only }
+
 let vernac_search s gopt r =
   let r = interp_search_restriction r in
   let env,gopt =
@@ -1695,18 +1774,28 @@ let vernac_search s gopt r =
     | Some g -> snd (Pfedit.get_goal_context g) , Some g
   in
   let get_pattern c = snd (intern_constr_pattern env c) in
+  let pr_search ref env c =
+    let pr = pr_global ref in
+    let pp = if !search_output_name_only
+      then pr
+      else begin
+        let pc = pr_lconstr_env env Evd.empty c in
+        hov 2 (pr ++ str":" ++ spc () ++ pc)
+      end
+    in Feedback.msg_notice pp
+  in
   match s with
   | SearchPattern c ->
-      msg_notice (Search.search_pattern gopt (get_pattern c) r)
+      Search.search_pattern gopt (get_pattern c) r pr_search
   | SearchRewrite c ->
-      msg_notice (Search.search_rewrite gopt (get_pattern c) r)
+      Search.search_rewrite gopt (get_pattern c) r pr_search
   | SearchHead c ->
-      msg_notice (Search.search_by_head gopt (get_pattern c) r)
+      Search.search_by_head gopt (get_pattern c) r pr_search
   | SearchAbout sl ->
-     msg_notice (Search.search_about gopt (List.map (on_snd (interp_search_about_item env)) sl) r)
+      Search.search_about gopt (List.map (on_snd (interp_search_about_item env)) sl) r pr_search
 
-let vernac_locate = function
-  | LocateAny (AN qid) -> msg_notice (print_located_qualid qid)
+let vernac_locate = let open Feedback in function
+  | 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)) ->
@@ -1736,7 +1825,7 @@ let vernac_focus gln =
     match gln with
       | None -> Proof.focus focus_command_cond () 1 p
       | Some 0 ->
-         Errors.error "Invalid goal number: 0. Goal numbering starts with 1."
+         CErrors.error "Invalid goal number: 0. Goal numbering starts with 1."
       | Some n ->
          Proof.focus focus_command_cond () n p)
 
@@ -1749,7 +1838,7 @@ let vernac_unfocus () =
 let vernac_unfocused () =
   let p = Proof_global.give_me_the_proof () in
   if Proof.unfocused p then
-    msg_notice (str"The proof is indeed fully unfocused.")
+    Feedback.msg_notice (str"The proof is indeed fully unfocused.")
   else
     error "The proof is not fully unfocused."
 
@@ -1777,7 +1866,7 @@ let vernac_bullet (bullet:Proof_global.Bullet.t) =
   Proof_global.simple_with_current_proof (fun _ p ->
     Proof_global.Bullet.put p bullet)
 
-let vernac_show = function
+let vernac_show = let open Feedback in function
   | ShowGoal goalref ->
     let info = match goalref with
       | OpenSubgoals -> pr_open_subgoals ()
@@ -1815,33 +1904,36 @@ let vernac_check_guard () =
     with UserError(_,s) ->
       (str ("Condition violated: ") ++s)
   in
-  msg_notice message
+  Feedback.msg_notice message
 
 exception End_of_input
 
 let vernac_load interp fname =
+  let interp x =
+    let proof_mode = Proof_global.get_default_proof_mode_name () in
+    Proof_global.activate_proof_mode proof_mode;
+    interp x in
   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 fname =
-    Envars.expand_path_macros ~warn:(fun x -> msg_warning (str x)) fname in
+    Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in
   let fname = CUnix.make_suffix fname ".v" in
   let input =
     let longfname = Loadpath.locate_file fname in
     let in_chan = open_utf8_file_in longfname in
-    Pcoq.Gram.parsable (Stream.of_channel in_chan) in
+    Pcoq.Gram.parsable ~file:longfname (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.
  * loc is the Loc.t of the vernacular command being interpreted. *)
 let interp ?proof ~loc locality poly c =
-  prerr_endline ("interpreting: " ^ Pp.string_of_ppcmds (Ppvernac.pr_vernac c));
+  prerr_endline (fun () -> "interpreting: " ^ Pp.string_of_ppcmds (Ppvernac.pr_vernac c));
   match c with
   (* Done later in this file *)
   | VernacLoad _ -> assert false
@@ -1854,8 +1946,6 @@ let interp ?proof ~loc locality poly c =
   | VernacError e -> raise e
 
   (* Syntax *)
-  | 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
@@ -1906,14 +1996,13 @@ let interp ?proof ~loc locality poly c =
       vernac_identity_coercion locality poly local id s t
 
   (* Type classes *)
-  | VernacInstance (abst, sup, inst, props, pri) ->
-      vernac_instance abst locality poly sup inst props pri
+  | VernacInstance (abst, sup, inst, props, info) ->
+      vernac_instance abst locality poly sup inst props info
   | VernacContext sup -> vernac_context poly sup
-  | VernacDeclareInstances (ids, pri) -> vernac_declare_instances locality ids pri
+  | VernacDeclareInstances insts -> vernac_declare_instances locality insts
   | VernacDeclareClass id -> vernac_declare_class id
 
   (* Solving *)
-  | VernacSolve (n,info,tac,b) -> vernac_solve n info tac b
   | VernacSolveExistential (n,c) -> vernac_solve_existential n c
 
   (* Auxiliary file and library management *)
@@ -1934,8 +2023,6 @@ let interp ?proof ~loc locality poly c =
   | VernacBackTo _ -> anomaly (str "VernacBackTo not handled by Stm")
 
   (* Commands *)
-  | 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) ->
@@ -1944,13 +2031,14 @@ let interp ?proof ~loc locality poly c =
       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 
+  | VernacArguments (qid, args, more_implicits, nargs, flags) ->
+      vernac_arguments locality qid args more_implicits nargs flags
   | VernacReserve bl -> vernac_reserve bl
   | 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
+  | VernacSetAppendOption (key,v) -> vernac_set_append_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
@@ -1963,16 +2051,15 @@ let interp ?proof ~loc locality poly c =
   | VernacSearch (s,g,r) -> vernac_search s g r
   | VernacLocate l -> vernac_locate l
   | VernacRegister (id, r) -> vernac_register id r
-  | VernacComments l -> if_verbose msg_info (str "Comments ok\n")
-  | VernacNop -> ()
+  | VernacComments l -> if_verbose Feedback.msg_info (str "Comments ok\n")
 
   (* The STM should handle that, but LOAD bypasses the STM... *)
-  | VernacAbort id -> msg_warning (str "VernacAbort not handled by Stm")
-  | VernacAbortAll -> msg_warning (str "VernacAbortAll not handled by Stm")
-  | VernacRestart -> msg_warning (str "VernacRestart not handled by Stm")
-  | VernacUndo _ -> msg_warning (str "VernacUndo not handled by Stm")
-  | VernacUndoTo _ -> msg_warning (str "VernacUndoTo not handled by Stm")
-  | VernacBacktrack _ -> msg_warning (str "VernacBacktrack not handled by Stm")
+  | VernacAbort id -> CErrors.errorlabstrm "" (str "Abort cannot be used through the Load command")
+  | VernacAbortAll -> CErrors.errorlabstrm "" (str "AbortAll cannot be used through the Load command")
+  | VernacRestart -> CErrors.errorlabstrm "" (str "Restart cannot be used through the Load command")
+  | VernacUndo _ -> CErrors.errorlabstrm "" (str "Undo cannot be used through the Load command")
+  | VernacUndoTo _ -> CErrors.errorlabstrm "" (str "UndoTo cannot be used through the Load command")
+  | VernacBacktrack _ -> CErrors.errorlabstrm "" (str "Backtrack cannot be used through the Load command")
   
   (* Proof management *)
   | VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t,None)] false
@@ -2012,25 +2099,23 @@ let check_vernac_supports_locality c l =
   match l, c with
   | None, _ -> ()
   | Some _, (
-      VernacTacticNotation _
-    | VernacOpenCloseScope _
+      VernacOpenCloseScope _
     | VernacSyntaxExtension _ | VernacInfix _ | VernacNotation _
     | VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _
     | VernacAssumption _ | VernacStartTheoremProof _
     | VernacCoercion _ | VernacIdentityCoercion _
     | VernacInstance _ | VernacDeclareInstances _
     | VernacDeclareMLModule _
-    | VernacDeclareTacticDefinition _
     | VernacCreateHintDb _ | VernacRemoveHints _ | VernacHints _
     | VernacSyntacticDefinition _
     | VernacArgumentsScope _ | VernacDeclareImplicits _ | VernacArguments _
     | VernacGeneralizable _
     | VernacSetOpacity _ | VernacSetStrategy _
-    | VernacSetOption _ | VernacUnsetOption _
+    | VernacSetOption _ | VernacSetAppendOption _ | VernacUnsetOption _
     | VernacDeclareReduction _
     | VernacExtend _ 
     | VernacInductive _) -> ()
-  | Some _, _ -> Errors.error "This command does not support Locality"
+  | Some _, _ -> CErrors.error "This command does not support Locality"
 
 (* Vernaculars that take a polymorphism flag *)
 let check_vernac_supports_polymorphism c p =
@@ -2044,13 +2129,13 @@ let check_vernac_supports_polymorphism c p =
     | VernacInstance _ | VernacDeclareInstances _
     | VernacHints _ | VernacContext _
     | VernacExtend _ | VernacUniverse _ | VernacConstraint _) -> ()
-  | Some _, _ -> Errors.error "This command does not support Polymorphism"
+  | Some _, _ -> CErrors.error "This command does not support Polymorphism"
 
 let enforce_polymorphism = function
   | None -> Flags.is_universe_polymorphism ()
   | Some b -> Flags.make_polymorphic_flag b; b
 
-(** A global default timeout, controled by option "Set Default Timeout n".
+(** A global default timeout, controlled by option "Set Default Timeout n".
     Use "Unset Default Timeout" to deactivate it (or set it to 0). *)
 
 let default_timeout = ref None
@@ -2098,17 +2183,17 @@ let with_fail b f =
            with
            | HasNotFailed as e -> raise e
            | e ->
-              let e = Errors.push e in
-              raise (HasFailed (Errors.iprint
-                (Cerrors.process_vernac_interp_error ~allow_uncaught:false ~with_header:false e))))
+              let e = CErrors.push e in
+              raise (HasFailed (CErrors.iprint
+                (ExplainErr.process_vernac_interp_error ~allow_uncaught:false ~with_header:false e))))
         ()
-    with e when Errors.noncritical e -> 
-      let (e, _) = Errors.push e in
+    with e when CErrors.noncritical e ->
+      let (e, _) = CErrors.push e in
       match e with
       | HasNotFailed ->
           errorlabstrm "Fail" (str "The command has not failed!")
       | HasFailed msg ->
-          if is_verbose () || !test_mode || !ide_slave then msg_info
+          if is_verbose () || !test_mode || !ide_slave then Feedback.msg_info
             (str "The command has indeed failed with message:" ++ fnl () ++ msg)
       | _ -> assert false
   end
@@ -2117,13 +2202,13 @@ 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"
+    | VernacProgram _ -> CErrors.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"
+    | VernacPolymorphic (b, c) -> CErrors.error "Polymorphism specified twice"
+    | VernacLocal _ -> CErrors.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 *)
@@ -2132,11 +2217,11 @@ let interp ?(verbosely=true) ?proof (loc,c) =
     | VernacTimeout (n,v) ->
         current_timeout := Some n;
         aux ?locality ?polymorphism isprogcmd v
-    | VernacRedirect (s, v) ->
-         Pp.with_output_to_file s (aux_list ?locality ?polymorphism isprogcmd) v;
-    | VernacTime v ->
+    | VernacRedirect (s, (_,v)) ->
+         Feedback.with_output_to_file s (aux false) v
+    | VernacTime (_,v) ->
         System.with_time !Flags.time
-          (aux_list ?locality ?polymorphism isprogcmd) v;
+          (aux ?locality ?polymorphism isprogcmd) v;
     | VernacLoad (_,fname) -> vernac_load (aux false) fname
     | c -> 
         check_vernac_supports_locality c locality;
@@ -2156,16 +2241,14 @@ let interp ?(verbosely=true) ?proof (loc,c) =
         | reraise when
               (match reraise with
               | Timeout -> true
-              | e -> Errors.noncritical e)
+              | e -> CErrors.noncritical e)
           ->
-            let e = Errors.push reraise in
+            let e = CErrors.push reraise in
             let e = locate_if_not_already loc e in
             let () = restore_timeout () in
             Flags.program_mode := orig_program_mode;
 	    ignore (Flags.use_polymorphic_flag ());
             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
diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli
index 451ccdb4..4e7fa4a0 100644
--- a/toplevel/vernacentries.mli
+++ b/toplevel/vernacentries.mli
@@ -59,3 +59,8 @@ val vernac_end_proof :
   ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit
 
 val with_fail : bool -> (unit -> unit) -> unit
+
+val command_focus : unit Proof.focus_kind
+
+val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Tacexpr.raw_red_expr ->
+  Evd.evar_map * Redexpr.red_expr) Hook.t
diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml
index 7fbd2b11..d81e3d6b 100644
--- a/toplevel/vernacinterp.ml
+++ b/toplevel/vernacinterp.ml
@@ -8,7 +8,7 @@
 
 open Util
 open Pp
-open Errors
+open CErrors
 
 type deprecation = bool
 type vernac_command = Genarg.raw_generic_argument list -> unit -> unit
@@ -42,6 +42,11 @@ let vinterp_map s =
 
 let vinterp_init () = Hashtbl.clear vernac_tab
 
+let warn_deprecated_command =
+  let open CWarnings in
+  create ~name:"deprecated-command" ~category:"deprecated"
+         (fun pr -> str "Deprecated vernacular command: " ++ pr)
+
 (* Interpretation of a vernac command *)
 
 let call ?locality (opn,converted_args) =
@@ -55,7 +60,7 @@ let call ?locality (opn,converted_args) =
       | Egramml.GramNonTerminal _ -> str "_"
       in
       let pr = pr_sequence pr_gram rules in
-      msg_warning (str "Deprecated vernacular command: " ++ pr)
+      warn_deprecated_command pr;
     in
     loc:= "Checking arguments";
     let hunk = callback converted_args in
@@ -66,7 +71,7 @@ let call ?locality (opn,converted_args) =
   with
     | Drop -> raise Drop
     | reraise ->
-        let reraise = Errors.push reraise in
+        let reraise = CErrors.push reraise in
         if !Flags.debug then
-	  msg_debug (str"Vernac Interpreter " ++ str !loc);
+	  Feedback.msg_debug (str"Vernac Interpreter " ++ str !loc);
         iraise reraise